Sayfalara Aktar Makrosu Hatası

[önder34]

Daha önce sitenin yardımıyla oluşturulmuş olan makro da e sütununda bir veya birden fazla satır atlayarak veri girişi yaparak aktar yaptığımda şu hata mesajını alıyorum. "son = Sheets(Sayfa).[B65536].End(3).Row + 1" sarı renge dönüyor birkaç değişiklik yaptım ama hatayı gideremedim .Satır atlayarak veri girişi yapılsa da dağıtımı nasıl yapabiliriz. Makronun tamamı şöye:

Sub Sayfalara_Dağıt()
Dim Sayfa As Variant, i As Long, son As Long, S1 As Worksheet
Set S1 = Sheets("Sayfa6")
For i = 1 To Worksheets.Count
If Sheets(i).Name <> "Sayfa6" Then
Sheets(i).Range("A365536").ClearContents
End If
Next i

For i = 3 To S1.[E65536].End(3).Row
Sayfa = S1.Cells(i, "E")
son = Sheets(Sayfa).[B65536].End(3).Row + 1
Sheets(Sayfa).Cells(son, "A") = son - 2
S1.Range("B" & i & ":C" & i & "" & i & ":E" & i & ":F" & i & ":G" & i & ":H" & i).Copy Sheets(Sayfa).Cells(son, "B")
Next i

MsgBox "Aktarım tamamlandı."
End Sub

 

[muysun35]

son = Worksheets("Sayfa6").Range(B65536).End(3).Row + 1 olarak değiştirin satırı

 

[önder34]

Sayın muysun35 yardımınız için teşekkür ederim ama sorun yine devam ediyor. Listede E sütununa farklı şube isimleri verilenler olduğu gibi verilmeyenlerde olacak bu nedenle veri girilmeyen satır aralığı değişebilir.(1,3 5,10 da olabilir )Dosyayı ekliyorum

 

[muysun35]

Dosyayı ekliyorum

Altın üye olmadığım için indiremiyorum dosyayı. eğer dosya.co ya da benzeri barındırma sitesine yükleyebilirseniz yardımcı olmaya çalışayım.

 

[Korhan Ayhan]

Boş satırları atlamak için bir IF sorgusu yeterli olacaktır.

Option Explicit

Sub Sayfalara_Dağıt()
    Dim Sayfa As Variant, i As Long, son As Long, S1 As Worksheet
    
    Set S1 = Sheets("Sayfa6")
    
    For i = 1 To Worksheets.Count
        If Sheets(i).Name <> S1.Name Then
            Sheets(i).Range("A3:D65536").ClearContents
        End If
    Next i
 
    For i = 3 To S1.[E65536].End(3).Row
        If S1.Cells(i, "E") <> "" Then
            Sayfa = S1.Cells(i, "E")
            son = Sheets(Sayfa).[B65536].End(3).Row + 1
            Sheets(Sayfa).Cells(son, "A") = son - 2
            S1.Range("B" & i).Resize(, 7).Copy Sheets(Sayfa).Cells(son, "B")
        End If
    Next i
 
    MsgBox "Aktarım tamamlandı."
End Sub

 

[muysun35]

Üstad çözmüş zaten.. Elinize sağlık Korhan Hocam.

 

[önder34]

Yardımlarınız için teşekkür ederim Sayın muysun35 ve Korhan Ayhan sorun çözüldü. Minnettarım .Elinize yüreğinize sağlık