Mesut AKCAN: Excel satırlarını belli sayıda bölme ve dosya veya sayfalara aktarma

Yayınlama: 20/02/2021

Güncelleme: 13/12/2022

Donanım Haber Forumundaki bir soru üzerine cevap olarak verdiğim Excel VBA kodlamaları buraya aktarıyorum.

Soru 1

Elimde içerisinde 40.000 satır veri bulunan bir Excel dosyası var. Bu 40.000 satırı 100'erli olarak bölmem gerekiyor.

Cevap: Aşağıdaki yazdığım VBA makrosu ile 100'erli satır olarak yeni eklenen sayfalara aktarılmaktadır.
Makroları kullanmak için;
Excel dosyası açıkken;
Excel durum çubuğundaki sayfa adında sağ tıkla / Kod görüntüle
Kod alanına aşağıdaki kodları ekle
Çalıştırmak için F5e bas ya da Excel'e geç / ALT+F8e bas makroyu seç / Çalıştır.

Sub SatirlariSayfalaraAktar_v1()
 'Excel satırlarını 100'erli olarak bölüp yeni sayfalara aktarır
 'makro: Mesut Akcan
 '15 Eylül 2018
 For n = 1 To Cells.SpecialCells(xlLastCell).Row Step 100
     satirlar = Str(n) & ":" & Trim(Str(n + 99))
     Rows(satirlar).EntireRow.Copy
     Sheets.Add After:=ActiveSheet
     ActiveSheet.Paste 
     DoEvents
 Next
 Sheets(1).Activate
 End Sub

Soru 2

Bu 100'lü bölümleri farklı yeni Excel dosyası olarak kaydedebilir miyiz.

Sub SatirlariDosyalaraAktar_v2()
'satırları 100'erli olarak bölüp yeni excel dosyalarına aktarır
'makro: Mesut Akcan
'16 Eylül 2018
klasor = ActiveWorkbook.Path & "\"
For n = 1 To Cells.SpecialCells(xlLastCell).Row Step 100
    satirlar = Trim(Str(n)) & ":" & Trim(Str(n + 99))
    Rows(satirlar).EntireRow.Copy
    dosyaNo = dosyaNo + 1
    Workbooks.Add
    ActiveSheet.Paste
    ActiveWorkbook.SaveAs Filename:=klasor & "Dosya_" & Trim(dosyaNo)
    ActiveWorkbook.Close
    DoEvents
Next
MsgBox "İşlem Tamama"
End Sub

Soru 3

Çıktıları CSV olarak kaydetmenin imkanı var mı?

Sub SatirlariDosyalaraAktar_v3()
 'satırları 100'erli olarak bölüp yeni excel CSV dosyalarına aktarır
 'makro: Mesut Akcan
 '12 Ekim 2018
 klasor = ActiveWorkbook.Path & "\"
 For n = 1 To Cells.SpecialCells(xlLastCell).Row Step 100
     satirlar = Trim(Str(n)) & ":" & Trim(Str(n + 99))
     Rows(satirlar).EntireRow.Copy
     Workbooks.Add
     ActiveSheet.Paste
     dosyaNo = dosyaNo + 1
     Dosya = "Dosya_" & Trim(dosyaNo)
     ActiveWorkbook.SaveAs Filename:=klasor & Dosya, FileFormat:=xlCSV
     ActiveWorkbook.Close
     DoEvents
 Next
 MsgBox "İşlem Tamam"
 End Sub

Soru 4

Benim de bu duruma benzer bir ihtiyacım var. Ben her satırın ayrı ayrı dosyalara bölünmesini istiyorum. Üstteki kodlar galiba 100'er 100'er bölüyor. Ben makroda 100 olan kısmı 1 yaptım ancak bu sefer bir üstündeki satırı silerek ayrı dosya oluşturdu yardım ederseniz çok sevinirim umarım kendimi ifade etmişimdir.

Cevap: Kodları biraz geliştirdim. Satır sayısını başlangıçta kendiniz belirleyebiliyorsunuz.

Sub SatirlariDosyalaraAktar_v4()
'satırları istenilen sayıda bölüp yeni excel dosyalarına aktarır
'makro: Mesut Akcan
'29 Temmuz 2019
Dim SatirSayisi As Long
Dim dosyaNo As Integer, n As Long
Dim klasor As String, satirlar As String, Dosya As String
 
SatirSayisi = Val(InputBox("Dosyalara bölünecek satır sayısını giriniz:"))
If SatirSayisi < 1 Then Exit Sub
klasor = ActiveWorkbook.Path & "\"
For n = 1 To Cells.SpecialCells(xlLastCell).Row Step SatirSayisi
    satirlar = Trim(Str(n)) & ":" & Trim(Str(n + SatirSayisi - 1))
    Rows(satirlar).EntireRow.Copy
    Workbooks.Add
    ActiveSheet.Paste
    dosyaNo = dosyaNo + 1
    Dosya = "Dosya_" & Format(dosyaNo, "000")
    ActiveWorkbook.SaveAs Filename:=klasor & Dosya
    ActiveWorkbook.Close
    DoEvents
Next
MsgBox "İşlem Tamam!"
End Sub

Soru 5

Excelde toplam 2000 satır var. 250'şerli olarak ayırmak istiyorum ama bu 250'lik kısımları TXT olarak kaydetmesini istiyorum.

Cevap: Kodlarda isteğinize uygun değişiklikler yaptım. Satır sayısını kod çalışınca size soracak. 250'de girebilirsin 100 de.

Sub SatirlariDosyalaraAktar_v5()
'satırları istenilen sayıda bölüp yeni TXT dosyalara aktarır
'makro: Mesut Akcan
'25 Eylül 2019
Dim SatirSayisi As Long
Dim dosyaNo As Integer, n As Long
Dim klasor As String, satirlar As String, dosyaAdi As String
Dim yeniDosya As Workbook

SatirSayisi = Val(InputBox("Dosyalara bölünecek satır sayısını giriniz:"))
If SatirSayisi < 1 Then Exit Sub
klasor = ActiveWorkbook.Path & "\"
For n = 1 To Cells.SpecialCells(xlLastCell).Row Step SatirSayisi
    satirlar = Trim(Str(n)) & ":" & Trim(Str(n + SatirSayisi - 1))
    Rows(satirlar).EntireRow.Copy
    dosyaNo = dosyaNo + 1
    dosyaAdi = "Dosya_" & Format(dosyaNo, "000")
    Set yeniDosya = Workbooks.Add
    With yeniDosya
        .Sheets(1).Paste
        .SaveAs Filename:=klasor & dosyaAdi, FileFormat:=xlText
        .Close
    End With
    DoEvents
Next
MsgBox "İşlem Tamam!"
End Sub

Soru 6

Parçalara bölünen dosyalarda başlık kısmı sadece 1. dosyada çıkıyor. Diğer tüm dosyalarda başlıklar olabilir mi?

Cevap: İsteğinize göre kodları değiştirdim. Umarım işinizi görür.

Sub SatirlariDosyalaraAktar_v6()
'makro: Mesut Akcan
'21 Şubat 2021
'mesutakcan.blogspot.com

'Excel sayfasındaki verileri istenilen satır sayısı kadar dosyalara böler
'Başlık satırı varsa bölünen dosyalara başlık ekler
Dim SatirSayisi As Long
Dim dosyaNo As Integer, n As Long, bs As Long, bsvar
Dim klasor As String, satirlar As String, dosyaAdi As String
Dim wb As Workbook, wbs As Worksheet
 
SatirSayisi = Val(InputBox("Dosyalara bölünecek satır sayısını giriniz:", , 100))
If SatirSayisi < 1 Then
    MsgBox "Satır sayısı 1 veya daha büyük olmalı!"
    Exit Sub
End If
klasor = InputBox("Dosyaların kaydedileceği klasör:", , ActiveWorkbook.Path) 'kayıt klasörü
If Right(klasor, 1) <> "\" Then klasor = klasor & "\" 'sonda \ yoksa ekle
bsvar = MsgBox("Başlık satırı var mı?", vbYesNo)
If bsvar = vbYes Then bs = 2 Else bs = 1 'başlık satırı varsa başlama satırı 2
Set wbs = ThisWorkbook.ActiveSheet 'makronun olduğu dosyanın aktif sayfası
Application.ScreenUpdating = False 'arkaplanda çalış
For n = bs To wbs.Cells.SpecialCells(xlLastCell).Row Step SatirSayisi
    satirlar = Trim(Str(n)) & ":" & Trim(Str(n + SatirSayisi - 1)) 'satır bölümleri: 2:101 gibi
    If bsvar = vbYes Then satirlar = "1:1," & satirlar 'başlık satırı varsa 1:1, eklenecek, 1:1,2:101 gibi
    wbs.Range(satirlar).Copy 'satırları kopyala
    dosyaNo = dosyaNo + 1 'dosya numarası
    dosyaAdi = "Dosya_" & Format(dosyaNo, "000") 'dosya adını biçimlendir. Dosya_001 gibi
    Set wb = Workbooks.Add 'yeni dosya aç
    With wb
        .Sheets(1).Paste 'dosyaya yapıştır
        .SaveAs Filename:=klasor & dosyaAdi 'dosyaya kaydet
        .Close 'dosyayı kapat
    End With
    DoEvents 'bekleyen işleri yürüt
Next
Application.ScreenUpdating = True 'arkaplanda çalışma iptal
MsgBox klasor & " klasöründe" & vbCr & dosyaNo & " adet dosya oluşturuldu.", vbInformation, "İşlem Tamam!" 'Bitti!
End Sub

Soru 7

Soru 6 daki kod çok güzel başlığı olduğu gibi alıyor. Excel çalışma dosyası olarak değil, hiç bir değişiklik yapmadan CSV olarak kaydetme şansı olur mu?

Cevap: İsteğinize göre kodları değiştirdim. Umarım işinizi görür.

dosyaFormati = xlCSV

satırını değiştirerek istenilen formatta kayıt edilebilir. Dosya Formatları

Option Explicit
Sub SatirlariDosyalaraAktar_v7()
'makro: Mesut Akcan
'19 Haziran 2022
'mesutakcan.blogspot.com

'Excel sayfasındaki verileri istenilen satır sayısı kadar dosyalara böler
'Başlık satırı varsa bölünen dosyalara başlık ekler
Dim satirSayisi As Long
Dim dosyaNo As Integer, n As Long, bs As Long, bsvar
Dim klasor As String, satirlar As String, dosyaAdi As String
Dim wb As Workbook, wbs As Worksheet

Dim dosyaFormati As XlFileFormat
'dosya formatları:
'https://docs.microsoft.com/tr-tr/office/vba/api/excel.xlfileformat
dosyaFormati = xlCSV  'excel CSV dosya formatı
'CSV dosyayı excelde düzgün açmak için dosya ilk satırına
'sep=, ekleyin. tırnak hariç
 
satirSayisi = Val(InputBox("Dosyalara bölünecek satır sayısını giriniz:", , 100))
If satirSayisi < 1 Then
    MsgBox "Satır sayısı 1 veya daha büyük olmalı!"
    Exit Sub
End If
klasor = InputBox("Dosyaların kaydedileceği klasör:", , ActiveWorkbook.Path) 'kayıt klasörü
If Right(klasor, 1) <> "\" Then klasor = klasor & "\" 'sonda \ yoksa ekle
bsvar = MsgBox("Başlık satırı var mı?", vbYesNo)
If bsvar = vbYes Then bs = 2 Else bs = 1 'başlık satırı varsa başlama satırı 2
Set wbs = ThisWorkbook.ActiveSheet 'makronun olduğu dosyanın aktif sayfası
Application.ScreenUpdating = False 'arkaplanda çalış
For n = bs To wbs.Cells.SpecialCells(xlLastCell).Row Step satirSayisi
    satirlar = Trim(Str(n)) & ":" & Trim(Str(n + satirSayisi - 1)) 'satır bölümleri: 2:101 gibi
    If bsvar = vbYes Then satirlar = "1:1," & satirlar 'başlık satırı varsa 1:1, eklenecek, 1:1,2:101 gibi
    wbs.Range(satirlar).Copy 'satırları kopyala
    dosyaNo = dosyaNo + 1 'dosya numarası
    dosyaAdi = "Dosya_" & Format(dosyaNo, "000") 'dosya adını biçimlendir. Dosya_001 gibi
    Set wb = Workbooks.Add 'yeni dosya aç
    With wb
        .Sheets(1).Paste 'dosyaya yapıştır
        .SaveAs Filename:=klasor & dosyaAdi, FileFormat:=dosyaFormati 'dosyaya kaydet
        .Close 'dosyayı kapat
    End With
    DoEvents 'bekleyen işleri yürüt
Next
Application.ScreenUpdating = True 'arkaplanda çalışma iptal
MsgBox klasor & " klasöründe" & vbCr & dosyaNo & " adet dosya oluşturuldu.", vbInformation, "İşlem Tamam!" 'Bitti!
End Sub

Soru 8

CSV dosya formatında kaydettiğimde veriler virgül ile ayırılıyor. Bu şekildeki dosyayı excel ile veya kullandığım paket program ile açtığımda satırdaki tüm veriler bir hücrede birleşmiş olarak açılıyor.

CSV dosyadaki verileri noktalı virgül ile ayırarak kaydetmek mümkün mü?

Cevap:

1. yol: Üstte belirttiğim gibi csv dosyada ilk satırın üstüne
sep=,

satırını ekleyip kaydedin. Excel ile düzgün açılacaktır.

2.yol: Aşağıdaki makroyu kullanın

Sub SatirlariDosyalaraAktar_v8()
'makro: Mesut Akcan
'13/12/2022
'http://mesutakcan.blogspot.com

'Excel sayfasındaki verileri istenilen satır sayısı kadar dosyalara böler
'Başlık satırı varsa bölünen dosyalara başlık ekler
'-yeni: CSV dosya noktalı virgülle ayırılarak kaydedilir.
Dim satirSayisi As Long
Dim dosyaNo As Integer, n As Long, bs As Long, bsvar
Dim klasor As String, satirlar As String, dosyaAdi As String
Dim wb As Workbook, wbs As Worksheet

Dim dosyaFormati As XlFileFormat
'dosya formatları:
'https://docs.microsoft.com/tr-tr/office/vba/api/excel.xlfileformat
dosyaFormati = xlCSV  'excel CSV dosya formatı
Const noktaliVirgul = True 'Veriler noktalı virgül ile ayrılır
'Verilerin virgül ile ayrılması için True yerine False değerini verin
 
satirSayisi = Val(InputBox("Dosyalara bölünecek satır sayısını giriniz:", , 100))
If satirSayisi < 1 Then
    MsgBox "Satır sayısı 1 veya daha büyük olmalı!"
    Exit Sub
End If
klasor = InputBox("Dosyaların kaydedileceği klasör:", , ActiveWorkbook.Path) 'kayıt klasörü
If Right(klasor, 1) <> "\" Then klasor = klasor & "\" 'sonda \ yoksa ekle
bsvar = MsgBox("Başlık satırı var mı?", vbYesNo)
If bsvar = vbYes Then bs = 2 Else bs = 1 'başlık satırı varsa başlama satırı 2
Set wbs = ThisWorkbook.ActiveSheet 'makronun olduğu dosyanın aktif sayfası
Application.ScreenUpdating = False 'arkaplanda çalış
For n = bs To wbs.Cells.SpecialCells(xlLastCell).Row Step satirSayisi
    satirlar = Trim(Str(n)) & ":" & Trim(Str(n + satirSayisi - 1)) 'satır bölümleri: 2:101 gibi
    If bsvar = vbYes Then satirlar = "1:1," & satirlar 'başlık satırı varsa 1:1, eklenecek, 1:1,2:101 gibi
    wbs.Range(satirlar).Copy 'satırları kopyala
    dosyaNo = dosyaNo + 1 'dosya numarası
    dosyaAdi = "Dosya_" & Format(dosyaNo, "000") 'dosya adını biçimlendir. Dosya_001 gibi
    Set wb = Workbooks.Add 'yeni dosya aç
    With wb
        .Sheets(1).Paste 'dosyaya yapıştır
        'dosyaya kaydet
        .SaveAs Filename:=klasor & dosyaAdi, FileFormat:=dosyaFormati, Local:=noktaliVirgul
        .Close 'dosyayı kapat
    End With
    DoEvents 'bekleyen işleri yürüt
Next
Application.ScreenUpdating = True 'arkaplanda çalışma iptal
MsgBox klasor & " klasöründe" & vbCr & dosyaNo & " adet dosya oluşturuldu.", vbInformation, "İşlem Tamam!" 'Bitti!
End Sub

Mesut AKCAN

Sayfalar

13 Aralık 2022 Salı

Excel satırlarını belli sayıda bölme ve dosya veya sayfalara aktarma