virgülle ayrılmış hücreler

[ihaveanidea]

Arkadaşlar dosyada 1. formatta olan veriyi (sarı) ikinci formata (yeşil) çevirmek istiyorum ve mal cins ve miktarları çok daha fazla da olabiliyor. Yardımcı olursanız çok memnun olurum. Teşekkürler

 

[Korhan Ayhan]

Merhaba,

Sayfa2 ye sütun başlıklarını aktardıktan sonra aşağıdaki kodu çalıştırın.

Option Explicit
 
Sub AKTAR()
    Dim S1, S2, X, Y, Veri1, Veri2, Satir
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Satir = 2
    
    S2.Range("A2:J" & Rows.Count).ClearContents
    
    For X = 2 To S1.Cells(Rows.Count, 1).End(3).Row
        If InStr(1, S1.Cells(X, "F"), ",") > 0 Then
            Veri1 = Split(S1.Cells(X, "F"), ",")
            Veri2 = Split(S1.Cells(X, "G"), ",")
            S2.Range("A" & Satir & ":E" & Satir + UBound(Veri1)).Value = S1.Range("A" & X & ":E" & X).Value
            S2.Range("H" & Satir & ":J" & Satir).Value = S1.Range("H" & X & ":J" & X).Value
            
            For Y = 0 To UBound(Veri1)
                S2.Cells(Satir, "F") = Veri1(Y)
                Satir = Satir + 1
            Next
            
            Satir = S2.Cells(Rows.Count, "G").End(3).Row + 1
            
            For Y = 0 To UBound(Veri2)
                S2.Cells(Satir, "G") = Veri2(Y)
                Satir = Satir + 1
            Next
        End If
    Next
    
    S2.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub