Soru Belli bir veriyi bulunca devamında gelen 3 satırı yandaki 3 kolona yapıştırma

[SATYON]

merhaba,

elimde dağınık bir excel listesi var. bu listede PRINT BOX kelimesini bulduğu her satırda PRINT BOX kelimesi dahil devamındaki 2 satırı (toplam 3 satır) kopyalayıp yandaki 3 kolona transpose olarak yapıştırmak istiyorum. Böylece marka model ve fiyattan oluşan bir liste oluşturmak istiyorum. örnek dosya https://we.tl/t-Qy39utbaxc

 

[veyselemre]

Sub TEST()
    For i = 1 To Cells(Rows.Count, 1).End(3).Row
        If Cells(i, 1) = "PRINT BOX" Then
            sat = sat + 1
            Cells(i, 1).Resize(3).Copy
            Cells(sat, 4).PasteSpecial Transpose:=True
        End If
    Next i
End Sub

 

[SATYON]

Sub TEST()
    For i = 1 To Cells(Rows.Count, 1).End(3).Row
        If Cells(i, 1) = "PRINT BOX" Then
            sat = sat + 1
            Cells(i, 1).Resize(3).Copy
            Cells(sat, 4).PasteSpecial Transpose:=True
        End If
    Next i
End Sub

çok teşekkür ederim tam istediğim gibi elinize sağlık

 

[SATYON]

Sub TEST()
    For i = 1 To Cells(Rows.Count, 1).End(3).Row
        If Cells(i, 1) = "PRINT BOX" Then
            sat = sat + 1
            Cells(i, 1).Resize(3).Copy
            Cells(sat, 4).PasteSpecial Transpose:=True
        End If
    Next i
End Sub

birşey daha sorabilir miyim. aynı listede "PRINT BOX" gibi "no name" ve "PERFECT" gibi başlıklar da var ayrı satırlarda. bu kelimeleri gördüğünde de aynı şekilde listeleme yapmasını nasıl sağlarım. ama istediğim tüm markaları içeren bir liste yapmak mümkün mü?

 

[veyselemre]

Sub TEST()
    Do While i < Cells(Rows.Count, 1).End(3).Row
        i = i + 1
        Select Case Cells(i, 1)
            Case "PRINT BOX", "no name", "PERFECT"
                sat = sat + 1
                Cells(i, 1).Resize(3).Copy
                Cells(sat, 4).PasteSpecial Transpose:=True
                i = i + 2
        End Select
    Loop
End Sub

 

[SATYON]

Sub TEST()
    Do While i < Cells(Rows.Count, 1).End(3).Row
        i = i + 1
        Select Case Cells(i, 1)
            Case "PRINT BOX", "no name", "PERFECT"
                sat = sat + 1
                Cells(i, 1).Resize(3).Copy
                Cells(sat, 4).PasteSpecial Transpose:=True
                i = i + 2
        End Select
    Loop
End Sub

Bayram tatili nedeniyle anca bakabildim. test edip bilgi vereceğim ilginiz için teşekkür ederim.

 

[SATYON]

Bayram tatili nedeniyle anca bakabildim. test edip bilgi vereceğim ilginiz için teşekkür ederim.

teşekkürler oldu.

 

[SATYON]

Sub TEST()
    Do While i < Cells(Rows.Count, 1).End(3).Row
        i = i + 1
        Select Case Cells(i, 1)
            Case "PRINT BOX", "no name", "PERFECT"
                sat = sat + 1
                Cells(i, 1).Resize(3).Copy
                Cells(sat, 4).PasteSpecial Transpose:=True
                i = i + 2
        End Select
    Loop
End Sub

teşekkürler oldu

 

[SATYON]

Sub TEST()
    Do While i < Cells(Rows.Count, 1).End(3).Row
        i = i + 1
        Select Case Cells(i, 1)
            Case "PRINT BOX", "no name", "PERFECT"
                sat = sat + 1
                Cells(i, 1).Resize(3).Copy
                Cells(sat, 4).PasteSpecial Transpose:=True
                i = i + 2
        End Select
    Loop
End Sub

Size birşey daha sormak istiyorum eğer sakıncası yok ise. yukarıdaki isteğime çok benzer bir isteğim daha var. yine karışık bir excel listem var. bu listede "stok yok" ibaresini bulduktan sonraki 3. satırı b kolonuna 6. satırı c kolonuna ve yine "stok yok" ibaresinden sonra bulduğu içinde "kdv" geçen ilk satırı c kolonuna yazdırmak istiyorum. yani karışık listeden özet bir liste yapmak istiyorum. örnek dosya ekte. yardımcı olabilirseniz çok sevinirim. https://www.dosya.tc/server30/goyz67/ORNEK.xlsx.html

 

[veyselemre]

Sub TEST()
    sat = 1
    Do While i < Cells(Rows.Count, 1).End(3).Row
        i = i + 1
        Select Case Cells(i, 1)
            Case "Stok Yok"
                Cells(i, 1).Select
                Cells(sat, 2) = Cells(i + 3, 1)
                Cells(sat, 3) = Cells(i + 6, 1)
                i = i + 6
                For ii = i To i + 20
                    If Cells(ii, 1) Like "*KDV*" Then
                        Cells(sat, 4) = Cells(ii, 1)
                        i = ii
                        Exit For
                    End If
                Next ii
                sat = sat + 1
        End Select
    Loop
End Sub

 

[SATYON]

Sub TEST()
    sat = 1
    Do While i < Cells(Rows.Count, 1).End(3).Row
        i = i + 1
        Select Case Cells(i, 1)
            Case "Stok Yok"
                Cells(i, 1).Select
                Cells(sat, 2) = Cells(i + 3, 1)
                Cells(sat, 3) = Cells(i + 6, 1)
                i = i + 6
                For ii = i To i + 20
                    If Cells(ii, 1) Like "*KDV*" Then
                        Cells(sat, 4) = Cells(ii, 1)
                        i = ii
                        Exit For
                    End If
                Next ii
                sat = sat + 1
        End Select
    Loop
End Sub

harikasınız çok teşekkür ederim