Bir hücre içerisindeki veriyi dört ayri hücreye ayirmak.

[yeappa]

Merhaba,

Asagidaki sekilde text ve rakam halinde tek hücrede yer alan verilerim var.

Sultan Can 14-112 Kirikkale
Deniz aydin 22-100 Manisa
RECEP YALÇIN 33-120 İzmir Karşıyaka
adem Demir 22-112 Antalya..
HALİL Özk.. 75-100 sinop Boyab..
songül kara 14-210 Muğla Fethiye

Bu verileri su halde ayiklamak istiyorum.

Bunun icin bir kod yazdim.

Sub veri_ayikla()
    Dim cell As Range, special As String

    For Each cell In Selection
        special = ""
        arr = Split(cell.text, " ")
        For i = LBound(arr) To UBound(arr)
            If InStr(arr(i), "-") > 0 Then
                special = arr(i)
                arr(i) = "-"
            End If
        Next i
        cell.Offset(0, 1).Value = Join(arr, " ")
        brr = Split(special, "-")
        cell.Offset(0, 2).Value = brr(0)
        cell.Offset(0, 3).Value = brr(1)
    Next cell

End Sub

Bazi verilerde istedigim sonucu veriyor bazilarinda vermiyor.
Asagidaki ornekte hic bir veriyi dogru olarak aktaramadi.

Islem yapilacak ve sonuc aktarilacak hucrelerin yerleri onemli degil.
Veriyi, islenen hucrenin bir yan hucrelerine girebilir.
Bu sorunu nasil asabilirim?

 

[Necdet]

Merhaba,
Aşağıdaki kodları dener misiniz? Verinin A sütununda olduğu varsayılmıştır.

Not : CreateObject("vbscript.regexp") ile daha kısa olur, onu bende merak ediyorum

Sub Ayır()

    Dim s   As Variant, _
        i   As Long, _
        j   As Integer
    
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        s = Split(Replace(Cells(i, "A"), Chr(160), " "), "-")
        j = InStr(StrReverse(s(0)), " ") - 1
        Cells(i, "D") = Right(s(0), j)
        Cells(i, "B") = Trim(Replace(s(0), Cells(i, "D"), ""))
        
        j = InStr(s(1), " ") - 1
        Cells(i, "E") = Left(s(1), j)
        Cells(i, "C") = Trim(Replace(s(1), Cells(i, "E"), ""))
    Next i
    
End Sub

 

[Haluk]

Merhaba,
Aşağıdaki kodları dener misiniz? Verinin A sütununda olduğu varsayılmıştır.

Not : CreateObject("vbscript.regexp") ile daha kısa olur, onu bende merak ediyorum

Necdet Bey;

Kodun "kısalığı" göreceli bir kavram olmakla birlikte, "Regular Expressions" metodu ile hazırlanmış alternatif ektedir.

.

 

[Necdet]

Necdet Bey;

Kodun "kısalığı" göreceli bir kavram olmakla birlikte, "Regular Expressions" metodu ile hazırlanmış alternatif ektedir.

.

Haluk bey, ben amacıma ulaştım yanıtlayacağınızı bekliyordum zaten.

Kısalıktan kastım işin hamallığını Regexp'e yıkmaktı.

Arkadaşımızın altın üyeliği olmadığı için dosyayı göremeyecek. Anımsatmak istedim.

 

[Haluk]

Ben de sana takılmak için demiştim zaten ....

Not-1: Senin RegExp konusunda yine böyle bir mesajın vardı, cevap yazmıştım ama senden bir dönüş olmamıştı.

Not-2: Soruyu soran kişi "Altın Üye" olursa, forumun tüm nimetlerinden faydalanabilir.

.

 

[Necdet]

Ben de sana takılmak için demiştim zaten ....

Not-1: Senin RegExp konusunda yine böyle bir mesajın vardı, cevap yazmıştım ama senden bir dönüş olmamıştı.

.

Kaynamıştır arada Haluk bey, kötü niyetim yoktur

 

[yeappa]

Merhaba,
Aşağıdaki kodları dener misiniz? Verinin A sütununda olduğu varsayılmıştır.

Not : CreateObject("vbscript.regexp") ile daha kısa olur, onu bende merak ediyorum

Sub Ayır()

    Dim s   As Variant, _
        i   As Long, _
        j   As Integer
  
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        s = Split(Cells(i, "A"), "-")
        j = InStr(StrReverse(s(0)), " ") - 1
        Cells(i, "D") = Right(s(0), j)
        Cells(i, "B") = Trim(Replace(s(0), Cells(i, "D"), ""))
      
        j = InStr(s(1), " ") - 1
        Cells(i, "E") = Left(s(1), j)
        Cells(i, "C") = Trim(Replace(s(1), Cells(i, "E"), ""))
    Next i
  
End Sub

Merhaba,
Emeginiz icin tesekkur ederim.

A2 hucresi secili iken makro butonu ile cagirdim.
Subscript out of range hatasi verdi.

A3 hucresi secili iken makro butonu ile cagirdim.
Subscript out of range hatasi verdi.


ilgili Debug;

        j = InStr(s(1), " ") - 1

 

[yeappa]

Haluk bey, ben amacıma ulaştım yanıtlayacağınızı bekliyordum zaten.

Kısalıktan kastım işin hamallığını Regexp'e yıkmaktı.

Arkadaşımızın altın üyeliği olmadığı için dosyayı göremeyecek. Anımsatmak istedim.

Ben de sana takılmak için demiştim zaten ....

Not-1: Senin RegExp konusunda yine böyle bir mesajın vardı, cevap yazmıştım ama senden bir dönüş olmamıştı.

Not-2: Soruyu soran kişi "Altın Üye" olursa, forumun tüm nimetlerinden faydalanabilir.

.

"Altin uyelik" gibi bir secenek oldugunu simdi ogreniyorum.
"Altin uyelik" statusune haiz degilim.

Bu sebeple yardim almaktan mahrum kaliyorum.
Tesekkurler.

 

[Necdet]

Merhaba,
Emeginiz icin tesekkur ederim.

A2 hucresi secili iken makro butonu ile cagirdim.
Subscript out of range hatasi verdi.

A3 hucresi secili iken makro butonu ile cagirdim.
Subscript out of range hatasi verdi.


ilgili Debug;

        j = InStr(s(1), " ") - 1

Herhangi bir hücreyi seçmeniz gerekmiyor. Verdiğim kodlar Tüm A sütununda çalışır.

Eksik olan verileri dikkate almadığım için hata almanız olası.

Hata veren hücre değerini burada belirtirseniz sizin daha önce verdiğiniz verilerle farkı var mı onu inceleme şansımız olur.

Siz A2 hücresi diyorsunuz ama belki A1000 hücresinde bu hatayı alıyor olabilirsiniz.

Bu yüzden paylaşım sitelerinden birine örnek dosyanızı yüklerseniz yardım alma şansınız çoğalır.

 

[yeappa]

Herhangi bir hücreyi seçmeniz gerekmiyor. Verdiğim kodlar Tüm A sütununda çalışır.

Eksik olan verileri dikkate almadığım için hata almanız olası.

Hata veren hücre değerini burada belirtirseniz sizin daha önce verdiğiniz verilerle farkı var mı onu inceleme şansımız olur.

Siz A2 hücresi diyorsunuz ama belki A1000 hücresinde bu hatayı alıyor olabilirsiniz.

Bu yüzden paylaşım sitelerinden birine örnek dosyanızı yüklerseniz yardım alma şansınız çoğalır.

Merhaba,
Ayır makrosunu bir buton yardimiyla cagiriyorum. Ayni hatayi veriyor.

Haklisiniz ilgili calisma dosyasi

 

[Korhan Ayhan]

Alternatif,

Sub Veri_Ayikla()
    Dim X As Long, Son As Long
    Dim Veri As Variant, Y As Integer
    Dim Ad As String, Yerleske As String
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Range("B2:E" & Rows.Count).ClearContents
    Son = Cells(Rows.Count, 1).End(3).Row
   
    For X = 2 To Son
        Ad = ""
        Yerleske = ""
        If Cells(X, 1) <> "" Then
            Veri = Split(Cells(X, 1), "-")
            Ad = Veri(0)
            Yerleske = Veri(1)
            For Y = 0 To 9
                Ad = Replace(Ad, Y, "")
                Yerleske = Replace(Yerleske, Y, "")
            Next
            Cells(X, 2) = VBA.Left(Ad, Len(Ad) - 1)
            Cells(X, 3) = Mid(Yerleske, 2, Len(Yerleske) - 1)
            Cells(X, 4) = Replace(Veri(0), Ad, "")
            Cells(X, 5) = Replace(Veri(1), Yerleske, "")
        End If
    Next
   
    Cells.Columns.AutoFit
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Necdet]

Merhaba,
2. mesajdaki kodları yeniledim. Sizin hücre içinde boşluk olarak gördüğünüz karakterler aslında boşluk karakteri değil. Sanırım verileri başka bir ortamdan aldınız.

Şimdi deneyiniz.

 

[yeappa]

Merhaba,
2. mesajdaki kodları yeniledim. Sizin hücre içinde boşluk olarak gördüğünüz karakterler aslında boşluk karakteri değil. Sanırım verileri başka bir ortamdan aldınız.

Şimdi deneyiniz.

Merhaba,

Evet paket bir yazilimin csv ciktisi. Hata kodlarinin sebebi olabilirler.
Tesekkurler

Alternatif,

Bilgilendirme uyarisi icin tesekkurler