Hücrede virgül ile ayrılmış parçaların ayrılması

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Hücrede virgül ile ayrılmış bölümlerin alt alta listelenmesi konusunda yardımcı olursanız çok makbule geçer.
Saygılarımla
Ornek_TK
Silinebilir dosya

 

[HücrelereFısıldayanAdam]

1- Veri, Metni Sütunlara dönüştür, Sınırlandırılmış, ayraç: virgül seçerek, her hücreyi sağdaki sütunlara parçalatabilirsiniz.
Sonra bunu alt alta sıralamak için: her sütun öncesine, A0001 le başlayan kodları yapıştırmanız gerek,
sonra bu ayrı sütunları, alt alta yapıştırıp yinelenenleri kaldır ile başta istediğiniz sonuca ulaşırsınız. Toplam 30-40 saniye sürer.

2-Otomatik alt alta sıralatmak için makro gerekir veya üstadlar karmaşık bir formül yazabilirler, ama baya uğraştırır.
Kişisine göre 2dk ile 2 saat sürebilir üstteki yöntem işinizi görür.

 

[dost]

Merhaba,

Sub Test()
Dim i, y, lRow, iRow As Long
Dim myArr() As String

lRow = Cells(Rows.Count, "C").End(xlUp).Row
iRow = 2

Range("H3").Resize(Cells(Rows.Count, "H").End(xlUp).Row, 3).ClearContents

For i = 3 To lRow
    myArr = Split(Cells(i, "D"), ",")
    For y = LBound(myArr) To UBound(myArr)
        iRow = iRow + 1
        Cells(iRow, "H") = IIf(y = 0, Cells(i, "B"), "")
        Cells(iRow, "I") = Cells(i, "C")
        Cells(iRow, "J") = Trim(myArr(y))
    Next y
Next i

MsgBox "İşlem tamam..."

End Sub

 

[Tevfik_Kursun]

1- Veri, Metni Sütunlara dönüştür, Sınırlandırılmış, ayraç: virgül seçerek, her hücreyi sağdaki sütunlara parçalatabilirsiniz. Sonra isterseniz bunu alt alta sıralamanız gerekir.

2-Otomatik alt alta sıralatmak için makro gerekir veya üstadlar karmaşık bir formül yazabilirler. Ama üstteki yöntem işinizi görür.

Merhaba,

Sub Test()
Dim i, y, lRow, iRow As Long
Dim myArr() As String

lRow = Cells(Rows.Count, "C").End(xlUp).Row
iRow = 2

Range("H3").Resize(Cells(Rows.Count, "H").End(xlUp).Row, 3).ClearContents

For i = 3 To lRow
    myArr = Split(Cells(i, "D"), ",")
    For y = LBound(myArr) To UBound(myArr)
        iRow = iRow + 1
        Cells(iRow, "H") = IIf(y = 0, Cells(i, "B"), "")
        Cells(iRow, "I") = Cells(i, "C")
        Cells(iRow, "J") = Trim(myArr(y))
    Next y
Next i

MsgBox "İşlem tamam..."

End Sub

ilginize teşekkür ederim, sizin makronuzu da hemen deneyeceğim. Denedim, çok güzel çalışıyor. Tekrar teşekkür ederim.
Saygılarımla