Tek hücrede yazılı olan metnin satır ve sütunlara göre düzenlenmesi

[deliaslan]

Öncelikle depremden dolayı vefat edenlere Allah rahmet eylesin, yaralılara acil şifalar versin. Ülkemize geçmiş olsun.

Benim sorum ham veri olarak gelen bir tabloda aynı kişiye ait verilerin olduğu tek hücre adının karşısında verilmektedir. Amaç bu verinin sayısı kaç adet olmasına bağlı olarak her bir ürün için yeni bir satır oluşturarak sütunlarda da özelliklerini vererek verileri kişi adına çoklu satıra kaydetmesini sağlamaktır.
Örnek dosyayı ekte paylaşıyorum. Yardımlarınız için şimdiden teşekkürler.

 

[dEdE]

Merhaba,
Örnek dosyanız ilişiktedir.

Sub Duzenle()
Set s1 = Sheets("ham_veri")
Set s2 = Sheets("istenen_format")
s2.Range("A2:I" & s2.Rows.Count).ClearContents
sat = 2

For j = 2 To s1.Cells(Rows.Count, 1).End(3).Row
myArr = s1.Range("A" & j & ":D" & j)
x = Split(myArr(1, 4), Chr(10))
    For i = 0 To UBound(x)
        If IsNumeric(Left(x(i), 1)) Then
            Cells(sat, 2) = s1.Cells(j, 2)
            Cells(sat, 3) = x(i)
            Cells(sat, 4) = Split(x(i + 1), ":")(1)
            Cells(sat, 5) = Split(x(i + 2), ":")(1)
            Cells(sat, 6) = Split(x(i + 3), ":")(1)
            Cells(sat, 7) = Split(x(i + 4), ":")(1)
            Cells(sat, 8) = Split(x(i + 5), ":")(1)
            sat = sat + 1
        End If
    Next i
Next j
Cells(2, 1) = 1
Range("A2:A" & sat - 1).DataSeries
End Sub

 

[deliaslan]

Merhaba,
Örnek dosyanız ilişiktedir.

Sub Duzenle()
Set s1 = Sheets("ham_veri")
Set s2 = Sheets("istenen_format")
s2.Range("A2:I" & s2.Rows.Count).ClearContents
sat = 2

For j = 2 To s1.Cells(Rows.Count, 1).End(3).Row
myArr = s1.Range("A" & j & ":D" & j)
x = Split(myArr(1, 4), Chr(10))
    For i = 0 To UBound(x)
        If IsNumeric(Left(x(i), 1)) Then
            Cells(sat, 2) = s1.Cells(j, 2)
            Cells(sat, 3) = x(i)
            Cells(sat, 4) = Split(x(i + 1), ":")(1)
            Cells(sat, 5) = Split(x(i + 2), ":")(1)
            Cells(sat, 6) = Split(x(i + 3), ":")(1)
            Cells(sat, 7) = Split(x(i + 4), ":")(1)
            Cells(sat, 8) = Split(x(i + 5), ":")(1)
            sat = sat + 1
        End If
    Next i
Next j
Cells(2, 1) = 1
Range("A2:A" & sat - 1).DataSeries
End Sub

Çok teşekkür ederim. Emeğinize sağlık