Text to columns

[erdemzi]

Merhaba
Aşağıdaki gibi 2 kolonum mevcuttur.
B kolonundaki değerleri ; ayracı ile ayırıp A kolonundaki değer ile satır satır yazdırmak istiyorum.
Text To Columns ile ile ayırıp transpose ile ilerleyebilirim fakat veri setim çok yüksek sayıda hücre içeriyor. Bu şekilde bir veriyi kod ile yazdırma konusunda yardımlarınız lütfen.

Örnek
A Kolonu B Kolonu
ANKARA Ahmet; Mehmet; Burak; Hasan; Hüseyin...
İSTANBUL Ayşe; Fatma; Elif;....
...
..
.

Yapılmak istenilen
A Kolonu B Kolonu
ANKARA Ahmet
ANKARA Mehmet
ANKARA Burak
ANKARA Hasan
ANKARA Hüseyin
İSTANBUL Ayşe
İSTANBUL Fatma
İSTANBUL Elif
...

 

[Muzaffer Ali]

Merhaba.

Sayfa1'de yazan verileri Sayfa2 de sıralar.

Sub test()
    Dim Bak As Long
    Dim Isimler() As String
    Dim BakIsim As Integer
    Dim Syf1 As Worksheet
    Dim Syf2 As Worksheet
    Dim Sira As Long
    
    Set Syf1 = Worksheets("Sayfa1")
    Set Syf2 = Worksheets("Sayfa2")
    
    For Bak = 1 To Syf1.Cells(Rows.Count, "A").End(xlUp).Row
        Isimler = Split(Syf1.Cells(Bak, "A"), " ")
        If UBound(Isimler) > 1 Then
            For BakIsim = 1 To UBound(Isimler)
                Sira = Syf2.Cells(Rows.Count, "A").End(xlUp).Row + 1
                Syf2.Cells(Sira, "A") = Replace(Isimler(0), ";", "")
                Syf2.Cells(Sira, "B") = Replace(Isimler(BakIsim), ";", "")
                
            Next
        End If
    Next
End Sub

 

[erdemzi]

İlginiz için teşekkürler, uygulamanız çalıştı ancak ben biraz eksik bilgi vermişim. Sizin formül boşlukları da ayrıca yazdırdı. Benim sorunum aşağıdaki gibi olunca çözülecektir.

ANKARA	AHMET DEMİR (TC:XXXXX) ; MEHMET GÜMÜŞ (TC:XXXXX)
ANKARA	AHMET DEMİR (TC:XXXXX)
ANKARA	MEHMET GÜMÜŞ (TC:XXXXX)

 

[Muzaffer Ali]

Sub test()
    Dim Bak As Long
    Dim Isimler() As String
    Dim BakIsim As Integer
    Dim Syf1 As Worksheet
    Dim Syf2 As Worksheet
    Dim Sira As Long
    
    Set Syf1 = Worksheets("Sayfa1")
    Set Syf2 = Worksheets("Sayfa2")
    
    For Bak = 1 To Syf1.Cells(Rows.Count, "A").End(xlUp).Row
        Isimler = Split(Syf1.Cells(Bak, "B"), ";")
        If UBound(Isimler) > 0 Then
            For BakIsim = 0 To UBound(Isimler)
                Sira = Syf2.Cells(Rows.Count, "A").End(xlUp).Row + 1
                Syf2.Cells(Sira, "A") = Syf1.Cells(Bak, "A")
                Syf2.Cells(Sira, "B") = Replace(Isimler(BakIsim), ";", "")
                
            Next
        End If
    Next
End Sub

 

[erdemzi]

Merhaba
Şimdi beklentimi tam karşıladı. Emeğinize sağlık.