时间戳

首页 > 解决方案 > 如何将具有多个电子表格的 excel 拆分为具有设定行数的相同数量的电子表格？

excel - 如何将具有多个电子表格的 excel 拆分为具有设定行数的相同数量的电子表格？

问题描述

我有一个 excel 文件，里面有 5 个不同的 excel 表（page1、page2、page3、page4、page5）。每个工作表也有一个标题。每张工作表有 160 条（它可以变化，但总是 20 的倍数）记录。我想创建 8 个不同的 excel 文件，其中有 20 条记录，每条记录都有相同的 5 张不同的工作表。

所以基本上它应该只从每张excel文件中获取20条记录并创建excel文件。160 条记录 / 20 = 8 个文件是逻辑。我尝试了很多东西，但找不到任何东西可以将记录拆分为 excel 文件中相同数量的 excel 表。

输出应该是

  1. 文件 1（第 1 页、第 2 页、第 3 页、第 4 页、第 5 页），其中包含 20 条第一条记录
  2. 文件2（page1、page2、page3、page4、page5）里面有21-40条记录
  3. 文件 3 (page1, page2, page3, page4, page5) 其中有 41-60 条记录
  4. 文件 4 (page1, page2, page3, page4, page5) 其中有 61-80 条记录
  5. 文件 5 (page1, page2, page3, page4, page5) 其中有 81-100 条记录，依此类推

我试过下面的宏

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 = 20                   '20 rows and 1 header

'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 "MyTest" & WorkbookCounter & ".xlsx", FileFormat:=51
wb.Close

'Increment file counter
WorkbookCounter = WorkbookCounter + 1
Next p

Application.ScreenUpdating = True
Set wb = Nothing
End Sub

我被困在一个点，我无法理解如何通过设置行数将具有多张工作表的 excel 拆分为相同数量的工作表到新的 excel 中。即20。

例如，在代码 Set ThisSheet = ThisWorkbook.ActiveSheet //这里实际上应该选择 excel 中的所有工作表，并且宏应该为 excel 中的每个工作表创建 20 条记录，并将其放入具有相同数量工作表的新 excel 文件中。谦虚的请求帮助我。

标签： excelvbaexport-to-excel

解决方案

这将是我的建议

Option Explicit

Function rgToCopy(ws As Worksheet, startRow As Long, noRows As Long, noCols As Long) As Range

    Dim rg As Range
    
    With ws
        Set rg = ws.Range(.Cells(startRow, 1), .Cells(startRow + noRows - 1, 1))
    End With
    
    Set rgToCopy = rg.Columns("A:" & columnLetter(noCols))
    
End Function

Function columnLetter(columnNumber As Long) As String
    columnLetter = Split(Cells(1, columnNumber).Address, "$")(1)
End Function


Sub CopyData()

    Dim i As Long
    Dim rg As Range
    Dim noOfRows As Long
    Dim NumOfColumns  As Long
    
    NumOfColumns = 2  ' Adjust to your needs
    noOfRows = 10     ' Adjust to your needs
    
    Dim shName As Variant
    Dim sheetNames As Variant
    Dim wks As Worksheet
    Dim wkb As Workbook
    
    sheetNames = Array("Tabelle1", "Tabelle2")  ' Adjust to your needs
    
    For i = 2 To 161 Step noOfRows    ' Adjust the 161 to your needs
        
        ' create new workbook
        Set wkb = Workbooks.Add
        ' add header <= not done
        
        Dim j As Long: j = 2
        
        For Each shName In sheetNames
            Set wks = ThisWorkbook.Sheets(shName)
            Set rg = rgToCopy(wks, i, noOfRows, NumOfColumns)
            rg.Copy
            wkb.Sheets(1).Paste Range("A" & j)
            j = j + noOfRows
        Next shName
        
        ' save and close workbook
        wkb.SaveAs ThisWorkbook.Path & "\" & i  ' Adjust to your needs
        wkb.Close False
        
    Next i
        
End Sub

请注意，我没有复制标题，这是留给你的。

推荐阅读