Bu kod ile çok satırlı excel dosyanızı parçalayarak oluşan parçaları yeni dosyalara kaydedebilirsiniz.
örnekte 50.000 satırlar halinde parçalama yapılmıştır siz isteğinize göre değiştirebilirsiniz.
Sub SplitAndSave()
'Değişkenler
Dim ws As Worksheet
Dim lRow As Long
Dim i As Long
Dim j As Integer
'Aktif sayfanın referansı
Set ws = ActiveSheet
'Son satırın numarasının alınması
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'Döngü başlatılması
For i = 2 To lRow Step 50000
'Yeni bir dosya oluşturulması
j = j + 1
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
'Verilerin kopyalanması
ws.Range("A1:XFD1").Copy _
Destination:=ActiveSheet.Range("A1")
ws.Range("A" & i & ":XFD" & i + 49999).Copy _
Destination:=ActiveSheet.Range("A2")
'Dosyanın kaydedilmesi
ActiveWorkbook.SaveAs FileName:= _
"Excel_Split\" & "Data_" & j & ".xls", _
FileFormat:=xlExcel8, CreateBackup:=False
Next i
End Sub
Kodun çalışması için, dosya kaydetme yolunu kendi bilgisayarınızda oluşturduğunuz klasörün yoluna güncellemelisiniz. Örnekte “/Users/YourUserName/Desktop/Excel_Split/” yolu kullanılmıştır.
Yorumlar