Excelde Satırlara Başka Sayfaya Ayırma Hakkında.

[maytro]

Merhaba
Örnekte excel sayfasında yaklaşık 12600 satırdan oluşan tekrarlayan sicil numaram var, ben bunları en fazla 2000 satır olarak ayırmak istiyorum. Ancak; verilerim tekrarlayan sicil numaralarımdan oluştuğu için ayrılacak sayfada sicil numarasının bitiminden almasını istiyorum. Sicil numarası yarısı başka sayfada yarısı diğer sayfada olmayacak şekilde, Buna göre ayrılacak sayfalarda satırlar 2000 satır olmaya bilir (Örn:1750 satır gibi) ama 2000 geçmesin istiyorum. Nasıl yapabilirim? yardımcı olursanız sevinirim.

Not: Dosyanın 2000. Satırında da açıklama yaptım.

 

[muhasebeciyiz]

makroyu çalıştırıp deneyiniz örnek dosyadaki gibimi olacak

 

[maytro]

makroyu çalıştırıp deneyiniz örnek dosyadaki gibimi olacak

Ayırma Tamam ama mesela Sayfa1 2000. satırda olan 1536813 sicil Sayfa2 de de var, bunu bir sayfada olması lazım, nasıl yapabilirim?

 

[muhasebeciyiz]

bunu denermisiniz

 

[maytro]

bunu denermisiniz

Elinize, emeğinize sağlık çok güzel olmuş, peki şu yapılabilir mi?; 2000. Satıra denk gelen sicil no 2001. satırda da aynı ise yada 1999. satırda aynı ise bir önceki sicil no ile satır kaçtaysa o ve öncesini alsın? böyle sayfalara kopyalasın?

Yani Sayfa1 de net olarak 2000. satırı almasına gerek olmayacak, bir önceki sicil no denk gelen satır sayısı 1655 ise onu alacak.?

 

[Korhan Ayhan]

Alternatif...

Option Explicit

Sub Split_Data()
    Dim S1 As Worksheet, WS As Worksheet, My_Array As Object, Key As Variant
    Dim My_Data As Variant, X As Long, XSum As Integer, No As Integer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    
    My_Data = S1.Range("A1").CurrentRegion.Value
    
    For X = 2 To UBound(My_Data)
        My_Array.Item(My_Data(X, 1)) = My_Array.Item(My_Data(X, 1)) + 1
    Next
    
    Application.DisplayAlerts = False
    
    For Each WS In ThisWorkbook.Sheets
        If WS.Name <> S1.Name Then WS.Delete
    Next
    
    Application.DisplayAlerts = True
    
    
    ReDim My_List(1 To 2000, 1 To 1)
    
    X = 1
    
    For Each Key In My_Array.Keys
        XSum = XSum + My_Array(Key)
        If XSum <= 2000 Then
            For X = X To X + My_Array(Key)
                'Debug.Print My_Array(Key)
                My_List(X, 1) = Key
            Next
            X = XSum + 1
        Else
            X = 1
            XSum = 0
            No = No + 1
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = No & ". Bölüm"
            Range("A1") = "Sicil Numarası"
            Range("A2").Resize(2000, 1) = My_List
            ReDim My_List(1 To 2000, 1 To 1)
        End If
    Next

    S1.Select
    
    Erase My_List
    Erase My_Data
    
    Set S1 = Nothing
    Set My_Array = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Veriler en fazla 2.000 satır olacak şekilde parçalara ayrılmıştır.", vbInformation
End Sub

 

[maytro]

Alternatif...

Option Explicit

Sub Split_Data()
    Dim S1 As Worksheet, WS As Worksheet, My_Array As Object, Key As Variant
    Dim My_Data As Variant, X As Long, XSum As Integer, No As Integer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Sayfa1")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
   
    My_Data = S1.Range("A1").CurrentRegion.Value
   
    For X = 2 To UBound(My_Data)
        My_Array.Item(My_Data(X, 1)) = My_Array.Item(My_Data(X, 1)) + 1
    Next
   
    Application.DisplayAlerts = False
   
    For Each WS In ThisWorkbook.Sheets
        If WS.Name <> S1.Name Then WS.Delete
    Next
   
    Application.DisplayAlerts = True
   
   
    ReDim My_List(1 To 2000, 1 To 1)
   
    X = 1
   
    For Each Key In My_Array.Keys
        XSum = XSum + My_Array(Key)
        If XSum <= 2000 Then
            For X = X To X + My_Array(Key)
                'Debug.Print My_Array(Key)
                My_List(X, 1) = Key
            Next
            X = XSum + 1
        Else
            X = 1
            XSum = 0
            No = No + 1
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = No & ". Bölüm"
            Range("A1") = "Sicil Numarası"
            Range("A2").Resize(2000, 1) = My_List
            ReDim My_List(1 To 2000, 1 To 1)
        End If
    Next

    S1.Select
   
    Erase My_List
    Erase My_Data
   
    Set S1 = Nothing
    Set My_Array = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Veriler en fazla 2.000 satır olacak şekilde parçalara ayrılmıştır.", vbInformation
End Sub

Siciller kayboluyor ve diğer sayfalara taşımıyor? 1.Bölüm sayfası ve diğerleri boş, Yanlış mı yapıştırdım acaba?
Örneğini yükledim..

 

[Korhan Ayhan]

İlk mesajdaki dosyanızı indirip denediğimde ben bir sorun yaşamıyorum.