Excellere bölme

[bthn35]

Merhaba,
Elimde 500.000 yada 1.00.000 satırlık datalarım oluyor, bunları her excel'de 100.000 satır olacak şekilde ayıracak makro yapılabilir mi?

 

[cems]

• Excel dosyanızda VBA Editörünü açın:
  • Alt + F11 tuşlarına basın.
  • Yeni bir modül eklemek için Insert > Module seçeneğine tıklayın.
• Aşağıdaki VBA kodunu kopyalayın ve modüle yapıştırın:

Sub SplitDataByRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim batchSize As Long
    Dim startRow As Long
    Dim endRow As Long
    Dim newWs As Worksheet
    Dim newWorkbook As Workbook
    Dim fileName As String
    Dim i As Long
    
    ' Veri sayfasını seçin
    Set ws = ThisWorkbook.Sheets(1) ' 1. sayfa olarak varsayalım
    
    ' Toplam satır sayısını alın
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' Her dosyada olacak satır sayısı
    batchSize = 100000
    
    ' Veriyi bölerek yeni dosyalar oluşturun
    startRow = 1
    Do While startRow <= lastRow
        ' Bitirilecek satır
        endRow = startRow + batchSize - 1
        If endRow > lastRow Then endRow = lastRow
        
        ' Yeni dosya oluşturun
        Set newWorkbook = Workbooks.Add
        Set newWs = newWorkbook.Sheets(1)
        
        ' Veriyi yeni dosyaya kopyalayın
        ws.Rows(startRow & ":" & endRow).Copy Destination:=newWs.Rows(1)
        
        ' Yeni dosyaya ad verin ve kaydedin
        fileName = "Data_Part_" & startRow & "_to_" & endRow & ".xlsx"
        newWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName
        
        ' Yeni dosyayı kapatın
        newWorkbook.Close False
        
        ' Sonraki bölüm için başlangıç satırını ayarlayın
        startRow = endRow + 1
    Loop
    
    MsgBox "Veri bölme işlemi tamamlandı!", vbInformation
End Sub

Kodu Açıklama:

• ws: Verilerin bulunduğu sayfa.
• lastRow: Verilerin son satırını belirler.
• batchSize: Her dosyada olması gereken satır sayısı (100.000).
• startRow ve endRow: Kopyalanacak satır aralığını belirler.
• newWorkbook ve newWs: Yeni dosya ve sayfa nesneleri.
• fileName: Yeni dosyaların ismini oluşturur ve kaydeder.
• Loop: Verilerin tamamı bölünüp yeni dosyalar oluşturulana kadar döngü devam eder.

Adımlar:

1. Makroyu çalıştırmadan önce, veri dosyanızın bulunduğu klasörde olduğunuzdan emin olun.
2. VBA editöründen F5 tuşuna basarak makroyu çalıştırın.
3. Her biri 100.000 satır içeren yeni Excel dosyaları, mevcut dosyanın bulunduğu dizine kaydedilecektir.

 

[bthn35]

Çok teşekkür ederim, son bir şey daha isteyebilir miyim? Yeni excel isimleri Data ile başlamak yerine makronun olduğu excelin adıyla başlasa olur mu?

 

[cems]

Bu sekilde dener misiniz

Sub SplitDataByRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim batchSize As Long
    Dim startRow As Long
    Dim endRow As Long
    Dim newWs As Worksheet
    Dim newWorkbook As Workbook
    Dim fileName As String
    Dim i As Long
    Dim baseFileName As String
  
    ' Veri sayfasını seçin
    Set ws = ThisWorkbook.Sheets(1) ' 1. sayfa olarak varsayalım
  
    ' Mevcut dosyanın adını al (uzantı olmadan)
    baseFileName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) ' .xlsm uzantısını çıkar
  
    ' Toplam satır sayısını alın
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
  
    ' Her dosyada olacak satır sayısı
    batchSize = 100000
  
    ' Veriyi bölerek yeni dosyalar oluşturun
    startRow = 1
    Do While startRow <= lastRow
        ' Bitirilecek satır
        endRow = startRow + batchSize - 1
        If endRow > lastRow Then endRow = lastRow
      
        ' Yeni dosya oluşturun
        Set newWorkbook = Workbooks.Add
        Set newWs = newWorkbook.Sheets(1)
      
        ' Veriyi yeni dosyaya kopyalayın
        ws.Rows(startRow & ":" & endRow).Copy Destination:=newWs.Rows(1)
      
        ' Yeni dosyaya ad verin ve kaydedin
        fileName = baseFileName & "_Part_" & startRow & "_to_" & endRow & ".xlsx"
        newWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName
      
        ' Yeni dosyayı kapatın
        newWorkbook.Close False
      
        ' Sonraki bölüm için başlangıç satırını ayarlayın
        startRow = endRow + 1
    Loop
  
    MsgBox "Veri bölme işlemi tamamlandı!", vbInformation
End Sub

Açıklama:

• baseFileName: Bu değişken, makronun çalıştığı Excel dosyasının adını alır ve .xlsm uzantısını kaldırarak sadece dosya ismini elde eder. Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) komutu ile uzantı kısmı (.xlsm veya .xlsx) çıkarılır.
• fileName: Yeni dosyanın adı, mevcut dosya adının başına _Part_X_to_Y eklenerek oluşturulur. Örneğin, eğer mevcut dosyanızın adı VeriDosyası.xlsm ise, yeni dosya isimleri şu şekilde olacaktır: VeriDosyası_Part_1_to_100000.xlsx.

 

[bthn35]

Oldu, çok teşekkür ederim

 

[cems]

kolay gelsin