Virgülden sonrakini ayrıştırma

[meleklerim]

İyi hafta sonları arkadaşlar
Elimde 2 sütundan oluşan bir liste var.
ilk sütun sayılardan ikinci sütun isimlerden oluşmuş.
(örnek dosya ekte)
Bazı satırlarda ikinci sütun birbirinden virgül ile ayrılmış isimler içeriyor.
Bu şekilde , ile ayrılmış isimleri İLK SÜTUNDAKİ SAYISI DEĞİŞMEDEN
alttaki satıra eklemek istiyorum
Örnek
3 Mehmet Ali
4 Selami Şahin, Azra Akın
7 Niyazi Bulut, Salman Aktar, Lale Solmaz

ise
makro sonucu
3 Mehmet Ali
4 Selami Şahin
4 Azra Akın
7 Niyazi Bulut
7 Salman Aktar
7 Lale Solmaz
şekline dönüşmesi gerekiyor.

* Bu şekil yaklaşık 10 bin satır var
* Bazı satırlarda 10-15 tane virgülle ayrılmış kişi var (maksimum 15)
* Ayrıştırma sonunda isimlerin önünde veya sonunda boşluk olmaması gerekiyor
* Ayrıştırma sonunda virgülden kurtulan isimlerden virgül sırası bozulmaması gerekiyor. Yani ilk yazılan ilk satıra, 2. yazılan onun altına, diğeri onun altına YAZILDIĞI SIRA ile geçmesi gerekiyor (örnek veride Lale Solmaz Salman Aktar'ın üstündeki satırda olmamalı)

ilgilenen arkadaşlar şimdiden teşekkürler
örnek dosya
http://s3.dosya.tc/server10/87hkap/virgulden_ayrilma.xlsx.html

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp çalıştırınız.

Sub Ayır()

    Dim i   As Long, _
        j   As Long, _
        k   As Integer, _
        d, _
        ShD As Worksheet, _
        Sha As Worksheet
    
    Set ShD = Sheets("data")
    Set Sha = Sheets("ayrıştır")
    
    Application.ScreenUpdating = False
    
    Sha.Range("A:B").ClearContents
    ShD.Range("A1:B1").Copy Sha.Range("A1")
    
    j = 1
    
    For i = 2 To ShD.Cells(Rows.Count, "A").End(3).Row
        d = Split(ShD.Cells(i, "B"), ",")
        If UBound(d) > 0 Then
            For k = 0 To UBound(d)
                j = j + 1
                Sha.Cells(j, "A") = ShD.Cells(i, "A")
                Sha.Cells(j, "B") = Trim(d(k))
            Next k
        Else
            j = j + 1
            Sha.Cells(j, "A") = ShD.Cells(i, "A")
            Sha.Cells(j, "B") = ShD.Cells(i, "B")
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "İŞLEM TAMAMLANMIŞTIR....", vbInformation, "excel.web.tr"
    
End Sub

 

[meleklerim]

teşekkür ederim, yalnız şöyle bir hata var,
olmayan sayıların satırlarını boş çıkarıyor.
Örnekte 5 ve 6 numaralar yok, 4 den direk 7 ye geçmiş
bu makro çalıştığında 5 ve 6 numaraları da satırlayıp boş bırakıyor
Onu da halledebilirseniz süper olacak

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub AYRIŞTIR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Son As Long, Satir As Long
    Dim Y As Byte, Veri As Variant
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("data")
    Set S2 = Sheets("ayrıştır")
    
    S2.Range("A:B").Clear
    S2.Range("A1:B1") = Array("NO", "KİŞİ")
    S2.Range("A1:B1").Font.Bold = True
    S2.Range("A1:B1").Interior.ColorIndex = 6
    S2.Range("A1:B1").HorizontalAlignment = 3
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Satir = 2
    
    For X = 2 To Son
        If S1.Cells(X, 1) <> "" And S1.Cells(X, 2) <> "" Then
            If InStr(1, S1.Cells(X, 2), ",") = 0 Then
                S2.Cells(Satir, 1) = S1.Cells(X, 1)
                S2.Cells(Satir, 2) = Trim(S1.Cells(X, 2))
                Satir = Satir + 1
            Else
                Veri = Split(S1.Cells(X, 2), ",")
                For Y = 0 To UBound(Veri)
                    S2.Cells(Satir, 1) = S1.Cells(X, 1)
                    S2.Cells(Satir, 2) = Trim(Veri(Y))
                    Satir = Satir + 1
                Next
            End If
        End If
    Next

    S2.Range("A:B").EntireColumn.AutoFit

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Bu arada Necdet Beyin önerdiği kod da bir problem göremedim. Atladığımız bir noktamı var?

 

[meleklerim]

Bu arada Necdet Beyin önerdiği kod da bir problem göremedim. Atladığımız bir noktamı var?

atlanılan nokta şu Korhan Bey,
Listede (a1) tüm sayılar yok.
Sayılar ardışık değil yani.
1 den 5 atlıyor, 3500 den 3525 e
bu durumda
1 Kişi adı
5 Kişi adı
olarak ayrıştıracağına
1 Kişi adı
2
3
4
5 Kişi adı
olarak ayrıştırıyor

 

[Korhan Ayhan]

Eklediğiniz dosyada denediğimde her iki kod içinde aynı sonucu alıyorum. Bu durumda benim önerdiğim kodun da hatalı sonuç vermesi gerekiyor.

 

[meleklerim]

Eklediğiniz dosyada denediğimde her iki kod içinde aynı sonucu alıyorum. Bu durumda benim önerdiğim kodun da hatalı sonuç vermesi gerekiyor.

evet, sizinki de aynı hatayı yapıyor.
Yani hata demeyelim de eksiklik diyelim.
Ben makronun ayrıştırdığı sayfada b sütununu filtreleyip "boş olanları" seçip
çıkan filtre sonucunu seçip "satır sil" diyerek tamamlıyorum.
O işlemi de makroya dahil etsek ya da refarans olarak sayıları otomatik değil de A sütununda olanları referans alsa eksiklik tamamlanacak

 

[Korhan Ayhan]

Demek istediğinizi anladım. Siz B sütunu boş olan satırların listelenmesini istemiyorsunuz.

#4 Nolu mesajımdaki kodu güncelledim. Tekrar deneyiniz.

 

[meleklerim]

teşekkürler Korhan Bey, makronun son hali isteğime tam cevap veriyor.
Siz de sağolun Necdet Bey, teşekkür ederim