Sayfalara böl makrosunda sayfalara sütun başlığı

Z

ziya

Katılım
8 Nisan 2005
Mesajlar
789
Excel Vers. ve Dili
Excel 2010 Türkçe
Kod: 
Sub SplitWorkbookToCSV() 
    Dim srcWs     As Worksheet
    Dim newWb     As Workbook
    Dim chunkSize As Long: chunkSize = 350
    Dim lastRow   As Long
    Dim startRow  As Long, endRow As Long
    Dim partIndex As Long
    Dim baseName  As String, folderPath As String, filePath As String
    
    Set srcWs = ThisWorkbook.Sheets(1)
    lastRow = srcWs.Cells(srcWs.Rows.Count, "A").End(xlUp).Row
    If lastRow = 0 Then
        MsgBox "Veri bulunamadı!", vbExclamation
        Exit Sub
    End If
    
    baseName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
    folderPath = ThisWorkbook.Path
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    partIndex = 0
    For startRow = 1 To lastRow Step chunkSize
        partIndex = partIndex + 1
        endRow = startRow + chunkSize - 1
        If endRow > lastRow Then endRow = lastRow
        
        Set newWb = Workbooks.Add(xlWBATWorksheet)
        srcWs.Rows(startRow & ":" & endRow).Copy _
            Destination:=newWb.Sheets(1).Rows(1)
        
        filePath = folderPath & "ÖIŞIK-2025" & "_" & _
                   Format(partIndex, "00") & ".csv"
        newWb.SaveAs Filename:=filePath, _
                     FileFormat:=xlCSV, _
                     CreateBackup:=False, local:=True
        newWb.Close SaveChanges:=False
    Next startRow
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Toplam " & partIndex & " dosya oluşturuldu.", vbInformation
End Sub
Yukarıda yazılı kodlar lk sayfaya "sütun başlıklarını" yazıyor, ilk sayfadan sonraki sayfalara sütun başlıklarını yazmıyor ve listeyi yazmaya doğrudan birinci satırdan devam ediyor.
Her sayfanın ilk satırına sütun başlıklarını yazmak konusunda yardım rica ediyorum.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,372
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Bunu deneyiniz...

C++: 
Sub SplitWorkbookToCSV()
    Dim srcWs     As Worksheet
    Dim newWb     As Workbook
    Dim chunkSize As Long: chunkSize = 350
    Dim lastRow   As Long
    Dim startRow  As Long, endRow As Long
    Dim partIndex As Long
    Dim baseName  As String, folderPath As String, filePath As String
    Dim headerRange As Range
    
    Set srcWs = ThisWorkbook.Sheets(1)
    lastRow = srcWs.Cells(srcWs.Rows.Count, "A").End(xlUp).Row
    If lastRow <= 1 Then
        MsgBox "Veri bulunamadı!", vbExclamation
        Exit Sub
    End If
    
    ' Başlık satırı (ilk satır)
    Set headerRange = srcWs.Rows(1)
    
    baseName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
    folderPath = ThisWorkbook.Path
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    partIndex = 0
    ' Veriler 2. satırdan başlar
    For startRow = 2 To lastRow Step chunkSize
        partIndex = partIndex + 1
        endRow = startRow + chunkSize - 1
        If endRow > lastRow Then endRow = lastRow
        
        Set newWb = Workbooks.Add(xlWBATWorksheet)
        
        ' Önce başlığı kopyala
        headerRange.Copy Destination:=newWb.Sheets(1).Rows(1)
        
        ' Ardından veri satırlarını başlığın altına ekle
        srcWs.Rows(startRow & ":" & endRow).Copy _
            Destination:=newWb.Sheets(1).Rows(2)
        
        ' Dosya ismi oluştur
        filePath = folderPath & baseName & "_" & Format(partIndex, "00") & ".csv"
        
        ' CSV olarak kaydet
        newWb.SaveAs Filename:=filePath, _
                     FileFormat:=xlCSV, _
                     CreateBackup:=False, _
                     Local:=True
        
        newWb.Close SaveChanges:=False
    Next startRow
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Toplam " & partIndex & " CSV dosyası oluşturuldu.", vbInformation
End Sub
 
M

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
1,095
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
Kod: 
Option Explicit

Sub SplitWorkbookToCSV_WithHeaders()
    Dim srcWs As Worksheet
    Dim newWb As Workbook
    Dim chunkSize As Long: chunkSize = 350
    Dim lastRow As Long
    Dim headerRow As Long: headerRow = 1
    Dim firstDataRow As Long: firstDataRow = headerRow + 1
    Dim startRow As Long, endRow As Long
    Dim partIndex As Long
    Dim baseName As String, folderPath As String, filePath As String
    Dim rngData As Range
   
    Set srcWs = ThisWorkbook.Sheets(1)
   
    lastRow = srcWs.Cells(srcWs.Rows.Count, "A").End(xlUp).Row
   
    If lastRow < firstDataRow Then
        MsgBox "Veri bulunamadı! (Başlık satırının altında veri yok.)", vbExclamation
        Exit Sub
    End If
   
    baseName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
    folderPath = ThisWorkbook.Path
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    partIndex = 0
   
    For startRow = firstDataRow To lastRow Step chunkSize
        partIndex = partIndex + 1
        endRow = startRow + chunkSize - 1
        If endRow > lastRow Then endRow = lastRow
       
        Set newWb = Workbooks.Add(xlWBATWorksheet)
       
        srcWs.Rows(headerRow).Copy Destination:=newWb.Sheets(1).Rows(1)
       
        Set rngData = srcWs.Range(srcWs.Rows(startRow), srcWs.Rows(endRow))
        rngData.Copy Destination:=newWb.Sheets(1).Rows(2)
       
        filePath = folderPath & "ÖIŞIK-2025" & "_" & Format(partIndex, "00") & ".csv"
        newWb.SaveAs Filename:=filePath, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
        newWb.Close SaveChanges:=False
    Next startRow
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    MsgBox "Toplam " & partIndex & " dosya oluşturuldu. (Her dosyada başlık satırı eklendi.)", vbInformation
End Sub
Sütun başlıklarının her dosyanın ilk satırında yer alması için, başlık satırını (genelde 1. satır) ayrıca kopyalayıp, veri parçalarını yeni dosyada 2. satırdan itibaren yapıştırmanız yeterli deneyeniz.Korhan hocamla ikimiz aynı anda gönderdik benimkide alternatif olsun
 
Z

ziya

Katılım
8 Nisan 2005
Mesajlar
789
Excel Vers. ve Dili
Excel 2010 Türkçe
Korhan Ayhan' Alıntı:
Merhaba,

Bunu deneyiniz...

C++: 
Sub SplitWorkbookToCSV()
    Dim srcWs     As Worksheet
    Dim newWb     As Workbook
    Dim chunkSize As Long: chunkSize = 350
    Dim lastRow   As Long
    Dim startRow  As Long, endRow As Long
    Dim partIndex As Long
    Dim baseName  As String, folderPath As String, filePath As String
    Dim headerRange As Range
   
    Set srcWs = ThisWorkbook.Sheets(1)
    lastRow = srcWs.Cells(srcWs.Rows.Count, "A").End(xlUp).Row
    If lastRow <= 1 Then
        MsgBox "Veri bulunamadı!", vbExclamation
        Exit Sub
    End If
   
    ' Başlık satırı (ilk satır)
    Set headerRange = srcWs.Rows(1)
   
    baseName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
    folderPath = ThisWorkbook.Path
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    partIndex = 0
    ' Veriler 2. satırdan başlar
    For startRow = 2 To lastRow Step chunkSize
        partIndex = partIndex + 1
        endRow = startRow + chunkSize - 1
        If endRow > lastRow Then endRow = lastRow
       
        Set newWb = Workbooks.Add(xlWBATWorksheet)
       
        ' Önce başlığı kopyala
        headerRange.Copy Destination:=newWb.Sheets(1).Rows(1)
       
        ' Ardından veri satırlarını başlığın altına ekle
        srcWs.Rows(startRow & ":" & endRow).Copy _
            Destination:=newWb.Sheets(1).Rows(2)
       
        ' Dosya ismi oluştur
        filePath = folderPath & baseName & "_" & Format(partIndex, "00") & ".csv"
       
        ' CSV olarak kaydet
        newWb.SaveAs Filename:=filePath, _
                     FileFormat:=xlCSV, _
                     CreateBackup:=False, _
                     Local:=True
       
        newWb.Close SaveChanges:=False
    Next startRow
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    MsgBox "Toplam " & partIndex & " CSV dosyası oluşturuldu.", vbInformation
End Sub
Genişletmek için tıkla ...
Yine KORHAN Hocam.
Çok teşekkür ederim.
 
Z

ziya

Katılım
8 Nisan 2005
Mesajlar
789
Excel Vers. ve Dili
Excel 2010 Türkçe
muhasebeciyiz' Alıntı:
Kod: 
Option Explicit

Sub SplitWorkbookToCSV_WithHeaders()
    Dim srcWs As Worksheet
    Dim newWb As Workbook
    Dim chunkSize As Long: chunkSize = 350
    Dim lastRow As Long
    Dim headerRow As Long: headerRow = 1
    Dim firstDataRow As Long: firstDataRow = headerRow + 1
    Dim startRow As Long, endRow As Long
    Dim partIndex As Long
    Dim baseName As String, folderPath As String, filePath As String
    Dim rngData As Range
  
    Set srcWs = ThisWorkbook.Sheets(1)
  
    lastRow = srcWs.Cells(srcWs.Rows.Count, "A").End(xlUp).Row
  
    If lastRow < firstDataRow Then
        MsgBox "Veri bulunamadı! (Başlık satırının altında veri yok.)", vbExclamation
        Exit Sub
    End If
  
    baseName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
    folderPath = ThisWorkbook.Path
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
  
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    partIndex = 0
  
    For startRow = firstDataRow To lastRow Step chunkSize
        partIndex = partIndex + 1
        endRow = startRow + chunkSize - 1
        If endRow > lastRow Then endRow = lastRow
      
        Set newWb = Workbooks.Add(xlWBATWorksheet)
      
        srcWs.Rows(headerRow).Copy Destination:=newWb.Sheets(1).Rows(1)
      
        Set rngData = srcWs.Range(srcWs.Rows(startRow), srcWs.Rows(endRow))
        rngData.Copy Destination:=newWb.Sheets(1).Rows(2)
      
        filePath = folderPath & "ÖIŞIK-2025" & "_" & Format(partIndex, "00") & ".csv"
        newWb.SaveAs Filename:=filePath, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
        newWb.Close SaveChanges:=False
    Next startRow
  
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
  
    MsgBox "Toplam " & partIndex & " dosya oluşturuldu. (Her dosyada başlık satırı eklendi.)", vbInformation
End Sub
Sütun başlıklarının her dosyanın ilk satırında yer alması için, başlık satırını (genelde 1. satır) ayrıca kopyalayıp, veri parçalarını yeni dosyada 2. satırdan itibaren yapıştırmanız yeterli deneyeniz.Korhan hocamla ikimiz aynı anda gönderdik benimkide alternatif olsun
Genişletmek için tıkla ...
Çok teşekkür ederim.
Korhan Hocama teşekkür ederken vakit kaybetmişim, cevabınızı yeni gördüm.
Her iki kodu ayrı ayrı denedim, gayet güzel çalışıyor, sağolun.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst