Jak podzielić arkusz kalkulacyjny na wiele arkuszy kalkulacyjnych za pomocą ustawionej liczby wierszy?

Question

Mam arkusz kalkulacyjny programu Excel (2007) z 433 wierszami (plus wiersz nagłówka u góry). Muszę podzielić to na 43 pojedynczych plików arkusza kalkulacyjnego z 10 wierszami i 1 z pozostałymi 3 wierszami. Byłoby lepiej, gdyby wiersz nagłówka znajdował się u góry każdego arkusza kalkulacyjnego. Jak mogę to zrobić? FYI, jestem trochę początkującym, jeśli chodzi o "wyższy poziom" funkcji Excela w ten sposób.

Dzięki!

Answer 1

Twoje makro dzieli tylko wszystkie wiersze z wybranego zakresu, w tym wiersz nagłówka w pierwszym wierszu (tak, że pojawi się tylko jeden raz, w pierwszym pliku). Zmodyfikowałem makro, o co prosisz; to jest łatwe, przejrzyj komentarze, które napisałem, aby zobaczyć, co robi.

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 

Mam nadzieję, że to pomoże.

Answer 2

I uaktualniony kod przez @Fer Garcia użytkowników komputerów Mac), zmiana tylko w ratowaniu plik metoda

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