Belirli aralıklarla kopyalama

[sahika51]

Arkadaşlar iyi akşamlar. Liste programı çok uzun. Ben iki kişi örnek olarak yazdım.
sheet1 deki e sütünundakki
e2:e13,
e32:e43
...
buşekilde gidiyor . burdaki bilgilerin Butona Liste sayfasına yatay olarak listelenmesi gerekiyor. Bu konuda yardım ederseniz sevinirim teşekkur ederim

 

[Necdet]

Merhaba,
Kodları inceleyin, ben Anne Adına kadar aktarmasını yaptın, gerisini siz tamamlayın.

Sub Aktar()

    Dim c   As Range, _
        Adr As String, _
        Sat As Long, _
        ShO As Worksheet, _
        ShL As Worksheet
    
    Set ShO = Sheets("Sheet1")
    Set ShL = Sheets("Liste")
    
    Sat = ShL.Cells(Rows.Count, "A").End(3).Row
    
    With ShO.Range("A:A")
        Set c = .Find("Nüfus Bilgileri", LookIn:=xlValues)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                Sat = Sat + 1
                ShL.Cells(Sat, "A") = c.Offset(0, 4)
                ShL.Cells(Sat, "B") = c.Offset(1, 4)
                ShL.Cells(Sat, "C") = c.Offset(2, 4)
                ShL.Cells(Sat, "D") = c.Offset(3, 4)
                ShL.Cells(Sat, "E") = c.Offset(4, 4)
                ShL.Cells(Sat, "F") = c.Offset(5, 4)
                
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
    
    MsgBox "Aktarım Bitmiştir....."
    
End Sub

 

[sahika51]

Teşekkür ederim. Bitmiş hali.



Sub Aktar()
Dim c As Range, _
Adr As String, _
Sat As Long, _
ShO As Worksheet, _
ShL As Worksheet

Set ShO = Sheets("Sheet1")
Set ShL = Sheets("Liste")

Sat = ShL.Cells(Rows.Count, "A").End(3).Row

With ShO.Range("A:A")
Set c = .Find("Nüfus Bilgileri", LookIn:=xlValues)
If Not c Is Nothing Then
Adr = c.Address
Do
Sat = Sat + 1
ShL.Cells(Sat, "A") = c.Offset(0, 4)
ShL.Cells(Sat, "B") = c.Offset(1, 4)
ShL.Cells(Sat, "C") = c.Offset(2, 4)
ShL.Cells(Sat, "D") = c.Offset(3, 4)
ShL.Cells(Sat, "E") = c.Offset(4, 4)
ShL.Cells(Sat, "F") = c.Offset(5, 4)
ShL.Cells(Sat, "g") = c.Offset(6, 4)
ShL.Cells(Sat, "h") = c.Offset(7, 4)
ShL.Cells(Sat, "ı") = c.Offset(8, 4)
ShL.Cells(Sat, "j") = c.Offset(9, 4)
ShL.Cells(Sat, "k") = c.Offset(10, 4)
ShL.Cells(Sat, "l") = c.Offset(11, 4)


Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With

MsgBox "Aktarım Bitmiştir....."

End Sub