bir sayfadaki içeriği belli bir kural cercevesınde diğer sayfalara ayırarak kopyalama

[airjordan2010]

Ekteki excel dosyasında nasıl bir macroya ihtiyacım olduğunu belirttim.Yardımlarınızı bekliyorum.

 

[hamitcan]

Sub Aktar()
    Sheets("Sayfa2").[a6:k5000].ClearContents
    j = 5
    With Sheets("Sayfa1")
        For i = 9 To .[a65536].End(3).Row
            If .Cells(i, 1) <> "Referans" And _
               .Cells(i, 1) <> "No" And _
               .Cells(i, 1) <> "" Then
    j = j + 1
               .Rows(i).Copy Sheets("Sayfa2").Rows(j)
            End If
        Next
    End With
    MsgBox "Aktarım Bitmiştir", vbInformation
End Sub

 

[airjordan2010]

senın yazdıgın macroda ıkıncı sheet e hepsını topladı.
Benım ıhtıyacım olan suydu aslında;
4-11.satır arası sayfa2'ye gidicek
12-17.satır arası sayfa3'e gidicek
18-24.satır arası sayfa4'e gitmesi gerekiyor.

ve bu satırlar aralıgındakı gıbı 25.satır sonrası devam ederse bunlarıda ayırabılmeli

bu şekilde düzeltebilirsen cok sevinirim.

 

[hamitcan]

Sub Aktar()
    Dim a() As Integer
    SayfaSil
    With Sheets("Sayfa1")
        For i = 4 To  .[a65536].End(3).Row
            If .Cells(i, 2) = "Fabrika Kodu" Or i =  .[a65536].End(3).Row  Then
            x = x + 1
            ReDim Preserve a(x)
            a(x) = i
            End If
        Next
    End With
    
For j = 1 To UBound(a) - 1
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("Sayfa1").Range("a" & a(j) & ":" & "k" & a(j + 1) - 1).Copy _
    Sheets(j + 1).[a1]
Next

End Sub

Sub SayfaSil()
    Application.DisplayAlerts = False
        For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "Sayfa1" Then sh.Delete
        Next
    Application.DisplayAlerts = True
End Sub

 

[airjordan2010]

Çok teşekkur ederim.On numara oldu.Eline sağlık