Sayfadan sayfaya aktarım

[kavramkurdu]

Birkaç bölümü olan aktarım sorunu var parça parça bana yardımcı olabilecek bir arkadaş arıyorum

 

[kavramkurdu]

arkadaşlar lütfen bir bana yardımcı olsun

 

[kavramkurdu]

kimse yardım etmeyecek mi !!!!!!!!!!!!

 

[Korhan Ayhan]

Selamlar,

Eğer verileriniz örnek dosyanızdaki gibiyse aşağıdaki kodu düzeltme yapmadan kullanabilirsiniz. İncelermisiniz.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Byte, Satır As Integer
    
    Set S1 = Sheets("X1")
    Set S2 = Sheets("X2")
    
    Application.ScreenUpdating = False
    
    S2.Range("AD9:AK65536").ClearContents

    On Error Resume Next
    S2.ListObjects("Liste1").Unlist
    On Error GoTo 0
 
    For X = 15 To S1.Range("A65536").End(3).Row Step 10
        For Y = 3 To 12
            If S1.Cells(X, Y) <> "" Then
                Satır = S2.Range("AF65536").End(3).Row + 1
                S2.Cells(Satır, "AE") = S1.Cells(X - 3, "B")
                S2.Cells(Satır, "AF") = S1.Cells(X - 2, Y)
                S2.Cells(Satır, "AH") = S1.Cells(X, Y)
            End If
        Next
    Next
    
    S2.ListObjects.Add(xlSrcRange, S2.Range("$AD$8:$AK$" & Satır), , xlYes).Name = "Liste1"
    S2.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[kavramkurdu]

çok teşekkür ederim .. Ellerinize emeğinize sağlık