Çoklu veriyi, tek veriye düşürme makrosu

[meleklerim]

Sevgili arkadaşlar
Bazı verilerimi tek veriye düşürmek istiyorum. Şöyle ki

Mevcut verilerin durumu
* A sütununda birbirinden "," ile ayrılmış kişi isimleri var
* Bunlardan kimilerinin görevi [ ] arasına yazılmış, kiminin görevi yok.

isteğim
* Bu kişileri B sütununa -görevlerini dikkate almadan- sadece isimlerinin alt alta sıralanması.
* Bu isimlerden birden fazla varsa teke düşürülmesi
* Teke düşürülen verilerin sonuna ;-@-;-@-;- ibaresinin eklenmesi
* İsmin sonunda veya başında boşluk olmaması ve A>Z sıralı olması
örnek olarak:
A Sütununda
Furat Emir
Neslihan Yalman [Senarist]
Osman F. Seden
-
Pelin Esmer [Senarist]
Özhan Eren, Osman F. Seden [Eser]
Ragıp Şevki Yeşim [Senarist]
-
Ömer Uğur [Senarist]
Furat Emir [Yapımcı]
Neslihan Yalman, Ragıp Şevki Yeşim (2) [süpervizor]

isteğim B sutünunda
-
Furat Emir;-@-;-@-;-
Neslihan Yaman;-@-;-@-;-
Osman F. Seden;-@-;-@-;-
Ömer Uğur;-@-;-@-;-
Özhan Eren;-@-;-@-;-
Pelin Esmer;-@-;-@-;-
Ragıp Şevki Yeşim;-@-;-@-;-
Ragıp Şevki Yeşim (2);-@-;-@-;-

Şimdiden yardımcı olacaklara teşekkürler

örnek dosya ektedir

http://dosya.co/781deag8klca/Kitap1.xlsx.html

 

[PLİNT]

Merhaba
Şöyle olabilir;

Private Sub CommandButton1_Click()
Dim a, b, c, x As Long
Dim d As Integer
Dim e As String
[B:B] = ""
For a = 1 To Cells(Rows.Count, "A").End(3).Row
If Trim(Cells(a, 1).Value) <> "-" Then
b = UBound(Split(Cells(a, 1).Value, ","))
For c = 0 To b
d = d + 1
e = Trim(Split(Cells(a, 1).Value, ",")(c))
Cells(d, "B") = Trim(Split(e, "[")(0)) & ";-@-;-@-;-"
If WorksheetFunction.CountIf(Range("B1:B" & d), Cells(d, "B").Value) > 1 Then d = d - 1
If Cells(d, "B").Text = ";-@-;-@-;-" Then Cells(d, "B") = ""
Next
End If
Next
x = Cells(Rows.Count, "B").End(xlUp).Row
Range("B1:B" & x).Sort Key1:=[b1], Order1:=xlAscending
End Sub

Ek dosyayı deneyiniz.

http://www.dosya.tc/server7/nhfhcp/Kitap1.zip.html

 

[meleklerim]

örnek belgede çalışmasına rağmen gerçek belgede

Cells(d, "B") = Trim(Split(e, "[")(0)) & ";-@-;-@-;-"

satırında hata verdi.

gerçek belgede tutarsız veri mi var yoksa 175 bin satır dolayında ondan olabilir mi?

http://dosya.co/2ukah0lyb2jn/Kitap2_Gerçek_Belge.xlsx.html

Gerçek belgeyi ekledim, ilgilenirseniz sevinirim.

 

[PLİNT]

Merhaba
Satırın çokluğundan değil, hücrenin birinde yanyana 2 ad. "," ; birindede hücrenin sonunda olduğu içinmiş.
Bu sorun ve çabuk sonlanması için bir birkaç ekleme yapmaya çalıştım.

Private Sub CommandButton1_Click()
Dim a, b, c, x As Long
Dim d As Integer
Dim e As String
[B:B] = ""
[COLOR="Red"]x = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:A" & x).Sort Key1:=[A1], Order1:=xlDescending[/COLOR]
For a = 1 To Cells(Rows.Count, "A").End(3).Row
If Trim(Cells(a, 1).Value) <> "-" Then
b = UBound(Split(Cells(a, 1).Value, ","))
[COLOR="Red"]On Error Resume Next[/COLOR]
For c = 0 To b
d = d + 1
e = Trim(Split(Cells(a, 1).Value, ",")(c))
Cells(d, "B") = Trim(Split(e, "[")(0)) & ";-@-;-@-;-"
If WorksheetFunction.CountIf(Range("B1:B" & d), Cells(d, "B").Value) > 1 Then d = d - 1
If Cells(d, "B").Text = ";-@-;-@-;-" Then Cells(d, "B") = ""
Next
End If
[COLOR="Red"]If Cells(a, 1) = "-" Then Exit For[/COLOR]
Next
x = Cells(Rows.Count, "B").End(xlUp).Row
Range("B1:B" & x).Sort Key1:=[b1], Order1:=xlAscending
End Sub

 

[veyselemre]

Alternatif olsun..

Sub test()
    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = vbTextCompare
    [c:c].ClearContents
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "\[\w+\]"
        For i = 1 To Cells(Rows.Count, 1).End(3).Row
            For Each r In Split(Cells(i, 1).Value, ",")
                If .test(r) Then r = Trim(.Replace(r, ""))
                If r <> "-" And r <> "" Then
                    dic.Item(Trim(r) & ";-@-;-@-;-") = ""
                End If
            Next r
        Next i
    End With
    kys = Application.Transpose(dic.keys)
    [c1].Resize(UBound(kys)).Value = kys
    Range("c:c").Sort Key1:=[c1], Order1:=xlAscending
End Sub

 

[meleklerim]

Her ikisi de hatasız ve süper çalışıyor arkadaşlar. Çok teşekkürler, elinize sağlık.