Sutundaki ayrı kategorileri satır çoğaltarak yazmak

[sefas]

Merhaba, hçbir yerde çözümüne ulaşmadığım bir problemim var.

Aşağıdaki fotoğrafta gördüğünüz gibi 4 veya 5 beden sütünlardaki değerleri tek bir satır altında toplamak fakat ait olduğu ürüne ait barkodları da kopyalayarak nasıl yapabiliriz.

Şimdiden teşekkürlerimi sunarım.
İyi aksamlar

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[sefas]

Öncelikle zaman ayırıp sorunumu çözdüğünüz için teşekkür ederim.

ben sütunları silerek göndermiştim, şimdi tam veri ile yapmaya çalışıyorum karmakarışık sonuç çıkıyor.

İlgili dosya
www.safaozturk.com/excel/Mail-Sefas-Aktar.xls

CH/CI/CJ/CK/CL/CM/CN sütunlarındaki bedenleri, AQ sütununa tıpkı sizin örnekte yaptığınız gibi diğer sütunları da koruyarak sıralamak istedim fakat bir yerde sanıyorum hata yapıyorum.

Bana yardımcı olur musunuz?

Teşekkür ederim

Düzenlediğim kod

Sub aktarr()
Application.ScreenUpdating = False
On Error Resume Next
Range("A2:C65536").Select
Selection.ClearContents
Range("A2").Select
Set s1 = ThisWorkbook.Worksheets("Sayfa1")
For i = 2 To s1.Range("AR65536").End(xlUp).Row
For z = 86 To 256
If s1.Cells(i, z) <> "" Then
sonsatir = s1.Range("A65536").End(xlUp).Row + 1
s1.Cells(sonsatir, 1) = s1.Cells(i, "bf")
s1.Cells(sonsatir, 2) = s1.Cells(i, "bg")
s1.Cells(sonsatir, 3) = s1.Cells(i, "bh")
s1.Cells(sonsatir, 4) = s1.Cells(i, "bj")
s1.Cells(sonsatir, 5) = s1.Cells(i, "bk")
s1.Cells(sonsatir, 6) = s1.Cells(i, "bl")
s1.Cells(sonsatir, 7) = s1.Cells(i, "bm")
s1.Cells(sonsatir, 8) = s1.Cells(i, "bn")
s1.Cells(sonsatir, 9) = s1.Cells(i, "bo")
s1.Cells(sonsatir, 10) = s1.Cells(i, "bp")
s1.Cells(sonsatir, 11) = s1.Cells(i, "bq")
s1.Cells(sonsatir, 12) = s1.Cells(i, "br")
s1.Cells(sonsatir, 13) = s1.Cells(i, "bs")
s1.Cells(sonsatir, 14) = s1.Cells(i, "bt")
s1.Cells(sonsatir, 15) = s1.Cells(i, "bu")
s1.Cells(sonsatir, 16) = s1.Cells(i, "bv")
s1.Cells(sonsatir, 17) = s1.Cells(i, "bw")
s1.Cells(sonsatir, 18) = s1.Cells(i, "bx")
s1.Cells(sonsatir, 19) = s1.Cells(i, "by")
s1.Cells(sonsatir, 20) = s1.Cells(i, "bz")
s1.Cells(sonsatir, 21) = s1.Cells(i, "ca")
s1.Cells(sonsatir, 22) = s1.Cells(i, "cb")
s1.Cells(sonsatir, 23) = s1.Cells(i, "cc")
s1.Cells(sonsatir, 24) = s1.Cells(i, "cd")
s1.Cells(sonsatir, 25) = s1.Cells(i, "ce")
s1.Cells(sonsatir, 26) = s1.Cells(i, "cf")
s1.Cells(sonsatir, 27) = s1.Cells(i, "cg")
s1.Cells(sonsatir, 28) = s1.Cells(i, "ch")
s1.Cells(sonsatir, 29) = s1.Cells(i, "ci")
s1.Cells(sonsatir, 30) = s1.Cells(i, "cj")
s1.Cells(sonsatir, 31) = s1.Cells(i, "ck")
s1.Cells(sonsatir, 32) = s1.Cells(i, "cl")
s1.Cells(sonsatir, 33) = s1.Cells(i, "cm")
s1.Cells(sonsatir, 34) = s1.Cells(i, "cn")
s1.Cells(sonsatir, 35) = s1.Cells(i, "co")
s1.Cells(sonsatir, 36) = s1.Cells(i, "cp")
s1.Cells(sonsatir, 37) = s1.Cells(i, "cq")
s1.Cells(sonsatir, 38) = s1.Cells(i, "cr")
s1.Cells(sonsatir, 39) = s1.Cells(i, "cs")
s1.Cells(sonsatir, 40) = s1.Cells(i, "ct")
s1.Cells(sonsatir, 41) = s1.Cells(i, "cu")
s1.Cells(sonsatir, 42) = s1.Cells(i, z)
End If
Next z
Next i
Call sıralaa
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[muygun]

Merhaba;
Eki deneyin.
Not alınan verilerin sıralamasında önce AQ sütunu (yani beden verisi) sıralandı.
Daha sonra E sütunu (yani model kodu verisi) sıralaması uygulandı.
İyi çalışmalar.

 

[sefas]

size ne kadar teşekkür etsem az. emeğinize sağlık. beni büyük dertten kurtardınız sağolun. çok teşekkür ederim, güzel bir haftasonu geçirmenizi dilerim...