Koşulla göre Kopyala Yapıştır

[kayserciyes]

D sütunundaki verileri H Sütununa yatay olarak kopyalamak istiyorum
Yalnız Binden fazla veri var TMFSI yazısından başlayacak bir sonraki TMFSİ yazısına kadar
Sonra bir alt Satıra geçip sonraki TMFSI yazısına kadar ki kısmı yapıştıracak

Siteden bulup uyarlayamadım yardımcı olursanız sevinirim
Örnek dosya ekliyorum. Şimdiden Teşekkür ederim

 

[Ömer]

Merhaba,

Deneyiniz.

Sub aktar()

    Dim sat As Long, c As Range, Adr As String, s As Long, son As Long

    Application.ScreenUpdating = False
    Range("H2:IV" & Rows.Count).ClearContents
    
    son = Cells(Rows.Count, "D").End(xlUp).Row
    
    sat = 2
    Set c = [D:D].Find("TMFSI", , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            If s > 0 Then
                Cells(s, "D").Resize(c.Row - s, 1).Copy
                Cells(sat, "H").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
                sat = sat + 1
            End If
            s = c.Row
            Set c = [D:D].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
    
    Cells(s, "D").Resize(son - s + 1, 1).Copy
    Cells(sat, "H").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
    Application.CutCopyMode = False
    Range("E2").Select
    
    MsgBox "Aktarım Bitti.", vbInformation
                
End Sub

 

[kayserciyes]

harikasın hocam ya
Valla Çok teşekkür ederim bir ik saniyede nasılda yaptı hepsini
Eline sağlık Teşekkür ediyorum