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

maytro · 22 Mart 2025

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 · 23 Mart 2025

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

maytro · 23 Mart 2025

muhasebeciyiz' Alıntı:
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 · 23 Mart 2025

bunu denermisiniz

maytro · 23 Mart 2025

muhasebeciyiz' Alıntı:
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 · 23 Mart 2025

Alternatif...

C++:

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, Y 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
    
    Key = My_Array.Keys
    
    For Y = LBound(Key) To UBound(Key)
        XSum = XSum + My_Array(Key(Y))
        If XSum <= 2000 Then
            For X = X To X + My_Array(Key(Y)) - 1
                My_List(X, 1) = Key(Y)
            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)
            Y = Y - 1
        End If
    Next

    If XSum > 0 Then
        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
    End If

    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 · 23 Mart 2025

Korhan Ayhan' Alıntı:

Alternatif...

C++:

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 · 24 Mart 2025

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

maytro · 24 Mart 2025

Korhan Ayhan' Alıntı:
İlk mesajdaki dosyanızı indirip denediğimde ben bir sorun yaşamıyorum.

Tekrar yaptım lakin sicilleri eksik getiriyor? Toplam 12000 civarı satırın 5.Bölüm de 8700 civarı sicil getiriyor, Sorun nedir acaba?

volki_112 · 24 Mart 2025

hocam b

Korhan Ayhan' Alıntı:

Alternatif...

C++:

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

hocam bu kodda ilk sayfadaki sicil 1756.satırda bitiyor diğer sayfaya 1757.satırdaki sicilden devam etmesi gerekirken atlayıp 2069.satırdan devam ediyor. Yani arada bir sicil noyu atlıyor. her sayfada bu şekilde 2000.satıra a denk gelen sicili atlayıp işleme devam ediyor.

Korhan Ayhan · 24 Mart 2025

Şimdi sakin kafayla bakınca sorunu tespit ettim.

#6 nolu mesajdaki kodu revize ettim. Tekrar deneyiniz.

volki_112 · 24 Mart 2025

Korhan Ayhan' Alıntı:
Şimdi sakin kafayla bakınca sorunu tespit ettim.

#6 nolu mesajdaki kodu revize ettim. Tekrar deneyiniz.

evet şimdi doğru yapıyor. @maytro 6 nolu mesajdaki kodu kullanınız.

maytro · 24 Mart 2025

Hepinizin eline emeğine sağlık çok teşekkür ederim. Şimdi oldu. Tamamdır

maytro · 28 Mart 2025

Merhaba
Aşağıda ki koda biraz ekleme yaptım. Ve yapma istediğin şey; A stünunu baz alarak A,B,C,D,E sütunlarında ki verileri de bölsün ama hata alıyorum yapamadım. Yardımcı olabilir misiniz?
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, Y 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:E1").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

Key = My_Array.Keys

For Y = LBound(Key) To UBound(Key)
XSum = XSum + My_Array(Key(Y))
If XSum <= 2000 Then
For X = X To X + My_Array(Key(Y)) - 1
My_List(X, 1) = Key(Y)
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:E1") = "Sicil Numarası"
Range("A2:E2").Resize(2000, 1) = My_List
ReDim My_List(1 To 2000, 1 To 1)
Y = Y - 1
End If
Next

If XSum > 0 Then
No = No + 1
Sheets.Add , Sheets(Sheets.Count)
ActiveSheet.Name = No & ". Bölüm"
Range("A1:A1") = "Sicil Numarası"
Range("A2:E2").Resize(2000, 1) = My_List
End If

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

muhasebeciyiz · 29 Mart 2025

Kod:

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, Y As Long, XSum As Integer, No As Integer
    Dim My_List() As Variant

    Application.ScreenUpdating = False
    Set S1 = Sheets("Sayfa1")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    
    My_Data = S1.Range("A1:E" & S1.Cells(S1.Rows.Count, 1).End(xlUp).Row).Value
    
    For X = 2 To UBound(My_Data, 1)
        My_Array.Item(My_Data(X, 1)) = My_Array.Item(My_Data(X, 1)) + 1
    Next X

    
    Application.DisplayAlerts = False
    For Each WS In ThisWorkbook.Sheets
        If WS.Name <> S1.Name Then WS.Delete
    Next WS
    Application.DisplayAlerts = True

    
    XSum = 0
    No = 0
    ReDim My_List(1 To 2000, 1 To 5)

    For Each Key In My_Array.Keys
        For Y = 1 To My_Array(Key)
            
            XSum = XSum + 1
            My_List(XSum, 1) = Key
            
            My_List(XSum, 2) = My_Data(Y + 1, 2)
            My_List(XSum, 3) = My_Data(Y + 1, 3)
            My_List(XSum, 4) = My_Data(Y + 1, 4)
            My_List(XSum, 5) = My_Data(Y + 1, 5)

            If XSum = 2000 Then
                
                No = No + 1
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = No & ". Bölüm"
                
                Sheets(No & ". Bölüm").Range("A1:E1").Value = Array("Sicil Numarası", "B", "C", "D", "E")
                
                Sheets(No & ". Bölüm").Range("A2:E" & XSum + 1).Value = My_List
                
                XSum = 0
                ReDim My_List(1 To 2000, 1 To 5)
            End If
        Next Y
    Next Key
    
    If XSum > 0 Then
        No = No + 1
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = No & ". Bölüm"
        Sheets(No & ". Bölüm").Range("A1:E1").Value = Array("Sicil Numarası", "B", "C", "D", "E")
        Sheets(No & ". Bölüm").Range("A2:E" & XSum + 1).Value = My_List
    End If

    S1.Select
    Application.ScreenUpdating = True

    MsgBox "Veriler en fazla 2.000 satır olacak şekilde parçalara ayrılmıştır.", vbInformation
End Sub

Yapılan Değişiklikler:

Veri Aralığı Genişletildi: My_Data'yı Range("A1:E" & S1.Cells(S1.Rows.Count, 1).End(xlUp).Row) olarak değiştirdim. Bu sayede verilerin yalnızca A1:E1 hücrelerinden başlaması sağlanmış oldu.
Sütun Veri Aktarımı: Verilerin yalnızca "Sicil Numarası" sütununu değil, A, B, C, D, E sütunlarındaki tüm verileri My_List dizisine aktarıyoruz.
My_List Yeniden Boyutlandırma: ReDim My_List(1 To 2000, 1 To 5) ile her sayfa için 2000 satır ve 5 sütunluk bir yapı kullanıyoruz.
Veri Yazma ve Sayfa Oluşturma: 2000 satıra kadar veriler yazıldığında, yeni bir sayfa oluşturuluyor ve bu sayfada veriler yazılmaya devam ediliyor. Son kalan veriler varsa, bir sayfa daha oluşturuluyor.

Bu şekilde kod, verilerin A, B, C, D ve E sütunlarını doğru şekilde ayırarak yeni sayfalara aktaracaktır.Lütfen deneyiniz

maytro · 7 Nisan 2025

muhasebeciyiz' Alıntı:
Kod:

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, Y As Long, XSum As Integer, No As Integer Dim My_List() As Variant Application.ScreenUpdating = False Set S1 = Sheets("Sayfa1") Set My_Array = VBA.CreateObject("Scripting.Dictionary") My_Data = S1.Range("A1:E" & S1.Cells(S1.Rows.Count, 1).End(xlUp).Row).Value For X = 2 To UBound(My_Data, 1) My_Array.Item(My_Data(X, 1)) = My_Array.Item(My_Data(X, 1)) + 1 Next X Application.DisplayAlerts = False For Each WS In ThisWorkbook.Sheets If WS.Name <> S1.Name Then WS.Delete Next WS Application.DisplayAlerts = True XSum = 0 No = 0 ReDim My_List(1 To 2000, 1 To 5) For Each Key In My_Array.Keys For Y = 1 To My_Array(Key) XSum = XSum + 1 My_List(XSum, 1) = Key My_List(XSum, 2) = My_Data(Y + 1, 2) My_List(XSum, 3) = My_Data(Y + 1, 3) My_List(XSum, 4) = My_Data(Y + 1, 4) My_List(XSum, 5) = My_Data(Y + 1, 5) If XSum = 2000 Then No = No + 1 Sheets.Add(After:=Sheets(Sheets.Count)).Name = No & ". Bölüm" Sheets(No & ". Bölüm").Range("A1:E1").Value = Array("Sicil Numarası", "B", "C", "D", "E") Sheets(No & ". Bölüm").Range("A2:E" & XSum + 1).Value = My_List XSum = 0 ReDim My_List(1 To 2000, 1 To 5) End If Next Y Next Key If XSum > 0 Then No = No + 1 Sheets.Add(After:=Sheets(Sheets.Count)).Name = No & ". Bölüm" Sheets(No & ". Bölüm").Range("A1:E1").Value = Array("Sicil Numarası", "B", "C", "D", "E") Sheets(No & ". Bölüm").Range("A2:E" & XSum + 1).Value = My_List End If S1.Select Application.ScreenUpdating = True MsgBox "Veriler en fazla 2.000 satır olacak şekilde parçalara ayrılmıştır.", vbInformation End Sub

Yapılan Değişiklikler:

Veri Aralığı Genişletildi: My_Data'yı Range("A1:E" & S1.Cells(S1.Rows.Count, 1).End(xlUp).Row) olarak değiştirdim. Bu sayede verilerin yalnızca A1:E1 hücrelerinden başlaması sağlanmış oldu.

Sütun Veri Aktarımı: Verilerin yalnızca "Sicil Numarası" sütununu değil, A, B, C, D, E sütunlarındaki tüm verileri My_List dizisine aktarıyoruz.

My_List Yeniden Boyutlandırma: ReDim My_List(1 To 2000, 1 To 5) ile her sayfa için 2000 satır ve 5 sütunluk bir yapı kullanıyoruz.

Veri Yazma ve Sayfa Oluşturma: 2000 satıra kadar veriler yazıldığında, yeni bir sayfa oluşturuluyor ve bu sayfada veriler yazılmaya devam ediliyor. Son kalan veriler varsa, bir sayfa daha oluşturuluyor.

Bu şekilde kod, verilerin A, B, C, D ve E sütunlarını doğru şekilde ayırarak yeni sayfalara aktaracaktır.Lütfen deneyiniz

Emeğiniz için teşekkür ederim

.
Denedim lakin yine 2000satırı kesiyor ve ayırıyor.Ancak: benim yapmak istediğim şey @Korhan Ayhan hocanın kodunu kullanarak diğer stünlardaki verileri getirebilmek nasıl yapabilirim? Entegre etmeye çalıştım olmadı...

pitchoute · 7 Nisan 2025

Merhaba, yedek alıp dener misiniz;

Kod:

Option Explicit

Sub Split_Data()
    Dim S1 As Worksheet, WS As Worksheet
    Dim srcData As Variant, destData As Variant
    Dim sicilDict As Object
    Dim sicil As Variant
    Dim srcRow As Long, destRow As Long, pageNum As Long
    Dim pageRowCount As Long
    Dim maxRows As Long
    
    maxRows = 2000
    
    Application.ScreenUpdating = False
    
    Set S1 = ThisWorkbook.Sheets("Sayfa1")
    
    srcData = S1.Range("A1").CurrentRegion.Value
    
    Application.DisplayAlerts = False
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name <> S1.Name Then WS.Delete
    Next WS
    Application.DisplayAlerts = True
    
    Set sicilDict = CreateObject("Scripting.Dictionary")
    
    For srcRow = 2 To UBound(srcData, 1)
        sicil = srcData(srcRow, 1)
        
        If Not sicilDict.Exists(sicil) Then
            sicilDict.Add sicil, 1
        Else
            sicilDict(sicil) = sicilDict(sicil) + 1
        End If
    Next srcRow
    
    pageNum = 1
    pageRowCount = 0
    destRow = 2
    
    Set WS = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    WS.Name = pageNum & ". Bölüm"
    
    For srcRow = 1 To 1
        For destRow = 1 To 1
            WS.Cells(destRow, 1).Resize(1, UBound(srcData, 2)).Value = _
                S1.Cells(srcRow, 1).Resize(1, UBound(srcData, 2)).Value
        Next destRow
    Next srcRow
    
    destRow = 2
    
    Dim keys As Variant
    keys = sicilDict.keys
    
    For Each sicil In keys
        Dim satirSayisi As Long
        satirSayisi = sicilDict(sicil)
        
        If pageRowCount + satirSayisi > maxRows Then
            pageNum = pageNum + 1
            pageRowCount = 0
            destRow = 2
            
            Set WS = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            WS.Name = pageNum & ". Bölüm"
            
            WS.Cells(1, 1).Resize(1, UBound(srcData, 2)).Value = srcData(1, 1)
        End If
        
        For srcRow = 2 To UBound(srcData, 1)
            If srcData(srcRow, 1) = sicil Then
                For destRow = 1 To UBound(srcData, 2)
                    WS.Cells(pageRowCount + 2, destRow).Value = srcData(srcRow, destRow)
                Next destRow
                pageRowCount = pageRowCount + 1
            End If
        Next srcRow
    Next sicil
    
    S1.Select
    Set S1 = Nothing
    Set sicilDict = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "Veriler en fazla " & maxRows & " satır olacak ve aynı sicil numaraları aynı sayfada olacak şekilde parçalara ayrılmıştır.", vbInformation
End Sub

Korhan Ayhan · 7 Nisan 2025

Bu şekilde deneyiniz.

C++:

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, Y 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 5)
    
    X = 1
    
    Key = My_Array.keys
    
    For Y = LBound(Key) To UBound(Key)
        XSum = XSum + My_Array(Key(Y))
        If XSum <= 2000 Then
            For X = X To X + My_Array(Key(Y)) - 1
                My_List(X, 1) = Key(Y)
                My_List(X, 2) = My_Data(X + 1, 2)
                My_List(X, 3) = My_Data(X + 1, 3)
                My_List(X, 4) = My_Data(X + 1, 4)
                My_List(X, 5) = My_Data(X + 1, 5)
            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:E1").Value = S1.Range("A1:E1").Value
            Range("A1:E1").Font.Bold = True
            Range("A2").Resize(2000, 5) = My_List
            Columns.AutoFit
            ReDim My_List(1 To 2000, 1 To 5)
            Y = Y - 1
        End If
    Next

    If XSum > 0 Then
        No = No + 1
        Sheets.Add , Sheets(Sheets.Count)
        ActiveSheet.Name = No & ". Bölüm"
        Range("A1:E1").Value = S1.Range("A1:E1").Value
        Range("A1:E1").Font.Bold = True
        Range("A2").Resize(2000, 5) = My_List
        Columns.AutoFit
    End If

    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 · Çarşamba saat 00:11'de

Korhan Ayhan' Alıntı:

Bu şekilde deneyiniz.

C++:

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, Y 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 5)
   
    X = 1
   
    Key = My_Array.keys
   
    For Y = LBound(Key) To UBound(Key)
        XSum = XSum + My_Array(Key(Y))
        If XSum <= 2000 Then
            For X = X To X + My_Array(Key(Y)) - 1
                My_List(X, 1) = Key(Y)
                My_List(X, 2) = My_Data(X + 1, 2)
                My_List(X, 3) = My_Data(X + 1, 3)
                My_List(X, 4) = My_Data(X + 1, 4)
                My_List(X, 5) = My_Data(X + 1, 5)
            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:E1").Value = S1.Range("A1:E1").Value
            Range("A1:E1").Font.Bold = True
            Range("A2").Resize(2000, 5) = My_List
            Columns.AutoFit
            ReDim My_List(1 To 2000, 1 To 5)
            Y = Y - 1
        End If
    Next

    If XSum > 0 Then
        No = No + 1
        Sheets.Add , Sheets(Sheets.Count)
        ActiveSheet.Name = No & ". Bölüm"
        Range("A1:E1").Value = S1.Range("A1:E1").Value
        Range("A1:E1").Font.Bold = True
        Range("A2").Resize(2000, 5) = My_List
        Columns.AutoFit
    End If

    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

@Korhan Ayhan Hocam, kod çalışmıyor, diğer sayfalara aktarım yapmıyor ama baka bilir misiniz?

Korhan Ayhan · Çarşamba saat 07:30'de

A-E aralığı tam olarak dolu hücrelerden oluşmuyor mu?

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

maytro

Ekli dosyalar

muhasebeciyiz

Ekli dosyalar

maytro

muhasebeciyiz

Ekli dosyalar

maytro

Korhan Ayhan

Administrator

maytro

Ekli dosyalar

Korhan Ayhan

Administrator

maytro

volki_112

Korhan Ayhan

Administrator

volki_112

maytro

maytro

muhasebeciyiz

maytro

pitchoute

Korhan Ayhan

Administrator

maytro

Korhan Ayhan

Administrator