Verileri bölmek - Bir milyon satırı ellişer binerlik 20 ayrı excel dosyasına bölmek

[pedasabyem]

Merhaba,

Excel 2010'da 1 000 000 satırlık veri var. A sütunundan H sütununa kadar da hücreler dolu.

Bu .xlsx dosyasını, 50şer bin satır olacak şekilde 20 ayrı excel dosyasına aktarabilir miyiz? Burada kaça bölündüğünden ziyade 50 000 er satır olacak şekilde bölünmesi.

Bununla ilgili bir konu buldum fakat kendi dosyama uyarlayamadım. Overflow hatası veriyor. Adresi:
http://www.excel.web.tr/f14/excel-de-datayy-bolmek-t81355.html

Saygılarımla

 

[Korhan Ayhan]

Merhaba,

Ana dosyanızı klasör içine yerleştirin. Daha sonra aşağıdaki kodu ana dosyanızda deneyin.

Sub DOSYALARA_AKTAR()
    Dim D1 As Workbook, D2 As Workbook, S1 As Worksheet, X As Long
    Dim Satir As Long, Dosya_Adi As String, Ek As String
    Dim Son_Satir As Long, Say As Integer, Zaman As Double
 
    On Error Resume Next
 
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
 
    Set D1 = ThisWorkbook
    Set S1 = D1.Sheets("Sayfa1")
 
    Satir = 50000
    Say = 1
    Ek = Format(Say, "000")
    Dosya_Adi = D1.Path & "\Dosya_" & Ek
    Son_Satir = S1.Cells(Rows.Count, 1).End(3).Row
 
    For X = 2 To Son_Satir Step Satir
        Set D2 = Workbooks.Add
        S1.Range("A1:H1").Copy D2.Sheets(1).Range("A1")
        If X + Satir <= Son_Satir Then
            S1.Range("A" & X & ":H" & X + Satir).Copy D2.Sheets(1).Range("A2")
        Else
            S1.Range("A" & X & ":H" & Son_Satir).Copy D2.Sheets(1).Range("A2")
        End If
        D2.SaveAs Dosya_Adi
        D2.Close 0
        Say = Say + 1
        Ek = Format(Say, "000")
        Dosya_Adi = D1.Path & "\Dosya_" & Ek
    Next
    Set S1 = Nothing
    Set D1 = Nothing
    Set D2 = Nothing
 
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz ; " & Format(Timer - Zaman, "0.000") & " saniyede tamamlanmıştır.", vbInformation
End Sub

 

[pedasabyem]

Tam olarak ihtiyacım olan buydu. Elinize sağlık, teşekkür ederim.