E-tablo, satır sayısı ayarlanmış birden çok elektronik tabloya nasıl bölünür?

Question

Bir Excel (2007) elektronik tablonun 433 satır (artı üstbilgi satırı üstte) var. Bunu, her biri 10 satır ve geriye kalan 3 satırı olan 43 ayrı elektronik tablo dosyasına bölmem gerekiyor. Her e-tablonun üst kısmında başlık satırının bulunması tercih edilir. Bunu nasıl başarabilirim? FYI, bu "üst düzey" Excel söz konusu olduğunda böyle bir yeni bir bitkinim.

Teşekkürler!

Answer 1

Makronuz, yalnızca ilk satırdaki başlık satırı dahil olmak üzere, seçilen aralıktaki tüm satırları böler (böylece ilk dosyada yalnızca bir kez görünecektir). Makroyu sorduğun şey için değiştirdim; Bu kolay, ne yaptığını görmek için yazdığım yorumları gözden geçirin.

Sub Test() 
    Dim wb As Workbook 
    Dim ThisSheet As Worksheet 
    Dim NumOfColumns As Integer 
    Dim RangeToCopy As Range 
    Dim RangeOfHeader As Range  'data (range) of header row 
    Dim WorkbookCounter As Integer 
    Dim RowsInFile     'how many rows (incl. header) in new files? 

    Application.ScreenUpdating = False 

    'Initialize data 
    Set ThisSheet = ThisWorkbook.ActiveSheet 
    NumOfColumns = ThisSheet.UsedRange.Columns.Count 
    WorkbookCounter = 1 
    RowsInFile = 10     'as your example, just 10 rows per file 

    'Copy the data of the first row (header) 
    Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns)) 

    For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1 
    Set wb = Workbooks.Add 

    'Paste the header row in new file 
    RangeOfHeader.Copy wb.Sheets(1).Range("A1") 

    'Paste the chunk of rows for this file 
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns)) 
    RangeToCopy.Copy wb.Sheets(1).Range("A2") 

    'Save the new workbook, and close it 
    wb.SaveAs ThisWorkbook.Path & "\test" & WorkbookCounter 
    wb.Close 

    'Increment file counter 
    WorkbookCounter = WorkbookCounter + 1 
    Next p 

    Application.ScreenUpdating = True 
    Set wb = Nothing 
End Sub 

Bu yardımcı olur umarım.

Mac kullanıcılarına @Fer Garcia tarafından kodunu güncellenen

Answer 2

;), sadece düz Excel'de dosya kaydetme yöntemi

Sub Test() 


Dim wb As Workbook 
    Dim ThisSheet As Worksheet 
    Dim NumOfColumns As Integer 
    Dim RangeToCopy As Range 
    Dim RangeOfHeader As Range  'data (range) of header row 
    Dim WorkbookCounter As Integer 
    Dim RowsInFile     'how many rows (incl. header) in new files? 

    Application.ScreenUpdating = False 

    'Initialize data 
    Set ThisSheet = ThisWorkbook.ActiveSheet 
    NumOfColumns = ThisSheet.UsedRange.Columns.Count 
    WorkbookCounter = 1 
    RowsInFile = 150     'as your example, just 10 rows per file 

    'Copy the data of the first row (header) 
    Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns)) 

    For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1 
    Set wb = Workbooks.Add 

    'Paste the header row in new file 
    RangeOfHeader.Copy wb.Sheets(1).Range("A1") 

    'Paste the chunk of rows for this file 
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns)) 
    RangeToCopy.Copy wb.Sheets(1).Range("A2") 

    'Save the new workbook, and close it 

    wb.SaveAs "Test" & WorkbookCounter & ".xls", FileFormat:=57 
    wb.Close 

    'Increment file counter 
    WorkbookCounter = WorkbookCounter + 1 
    Next p 

    Application.ScreenUpdating = True 
    Set wb = Nothing 
End Sub