Soru aktar

[sirkülasyon]

Liste Sayfasının AD5 : AI aralığında hangi satırlar dolu ise
Sayfa2' nin B5 : I10 aralığını önce temizleyecek sonra da alt alta aktaracak bir koda ihtiyacım var. Yardımcı olabilir misiniz?

 

[Ömer]

Merhaba,

Deneyiniz.

Sub aktar()

    Dim S1 As Worksheet, S2 As Worksheet, son As Long, sat As Long, s As Byte, i As Long
    
    Set S1 = Sheets("Liste")
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    S2.Range("B5:J" & Rows.Count).Clear
    
    If WorksheetFunction.CountA(S1.Range("AD5:AL" & Rows.Count)) = 0 Then Exit Sub
    
    son = S1.Range("AD5:AL" & Rows.Count).Find("*", , , , xlByRows, xlPrevious).Row
    sat = 5
    
    For i = 5 To son
        s = WorksheetFunction.CountA(S1.Cells(i, "AD").Resize(1, 9))
        If s > 0 Then
            S1.Cells(i, "AD").Resize(1, 9).Copy S2.Cells(sat, "B")
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

 

[sirkülasyon]

Ömer abi sağ olasın.
Teşekkür ederim