Soru Başka Sayfaya Koşullu Veri Kopyalama

[katip06]

merhaba, sayfada bulunan verilerimi yan sayfaya alt alta (boşluklar hariç) sıralamak istiyorum, yardımcı olabilir misiniz? Şimdiden teşekkür ederim.

 

[YUSUF44]

Aşağıdaki makroyu deneyin:

Sub aktar()
Set s1 = Sheets("DEPO")
Set s2 = Sheets("DEPO TOPLU SERİ")
eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
s2.Range("A2:B" & eski).ClearContents
For sira = 4 To 148 Step 24
    For sut = 3 To 17
        If WorksheetFunction.CountA(s1.Range(s1.Cells(sira, sut), s1.Cells(sira + 19, sut))) > 0 Then
            yeni = s2.Cells(Rows.Count, "B").End(3).Row + 1
            s1.Range(s1.Cells(sira, sut), s1.Cells(sira + 19, sut)).Copy s2.Cells(yeni, "B")
        End If
    Next
Next
son = s2.Cells(Rows.Count, "B").End(3).Row
s2.Range("B1:B" & son).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
son1 = s2.Cells(Rows.Count, "B").End(3).Row

For i = 2 To son1
    s2.Cells(i, "A") = i - 1
Next
End Sub

 

[katip06]

Aşağıdaki makroyu deneyin:

Sub aktar()
Set s1 = Sheets("DEPO")
Set s2 = Sheets("DEPO TOPLU SERİ")
eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
s2.Range("A2:B" & eski).ClearContents
For sira = 4 To 148 Step 24
    For sut = 3 To 17
        If WorksheetFunction.CountA(s1.Range(s1.Cells(sira, sut), s1.Cells(sira + 19, sut))) > 0 Then
            yeni = s2.Cells(Rows.Count, "B").End(3).Row + 1
            s1.Range(s1.Cells(sira, sut), s1.Cells(sira + 19, sut)).Copy s2.Cells(yeni, "B")
        End If
    Next
Next
son = s2.Cells(Rows.Count, "B").End(3).Row
s2.Range("B1:B" & son).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
son1 = s2.Cells(Rows.Count, "B").End(3).Row

For i = 2 To son1
    s2.Cells(i, "A") = i - 1
Next
End Sub

Çok teşekkür ederim YUSUF44 hocam, elinize emeğinize sağlık, şu an bi sorun yok gibi, sağolun.