Excel VBA 将单个 Excel 工作表拆分为多个包含多个工作表的工作簿

Question

我想将一个大的 Excel 工作表拆分为多个工作簿，其中工作表数量不同。

示例：

BBB 217
BBB 218
BBB 219
BBB 220
BBB 221
BBB 222
BBB 223
BBB 224
BBB 225
BBB 226
CCC 300
CCC 301
CCC 302
CCC 303
CCC 304
CCC 305
CCC 306
DDD 444
DDD 445
DDD 446
DDD 447

名为 BBB 的工作簿有第 217-226 页，CCC 有 300-306 页，DDD 有 444-447 页。工作簿名称从 B2 开始，相应的工作表从 C2 开始。

Answer 1

这应该可以。不是很简洁，但所有评论都会告诉您它是如何工作的，您可以进行必要的更改。将“AAA”行上的文件夹路径更改为您的文件夹路径。

Sub splitWorkbooksWorksheet()

Dim splitPath As String

Dim w As Workbook 'added workbook objects
Dim ws As Worksheet 'added worksheet objects
Dim wsh As Worksheet 'current active worksheet

Dim i As Long, j As Long
Dim lastr As Long
Dim wbkName As String
Dim wksName As String

Set wsh = ThisWorkbook.Worksheets(1)
splitPath = "G:\splitWb\" 'AAA --- PATH TO FOLDER WHERE TO SAVE WORKBOOKS

'last row based on column C worksheet names
lastr = wsh.Cells(Rows.Count, 3).End(xlUp).Row

'workbook object
Set w = Workbooks.Add

'this loop through each rows from row 1
'and set new worksheets in workbook w
'check if next rows carries the same
'workbook name if not save and close workbook w
For i = 1 To lastr
  wbkName = wsh.Cells(i, 2)
  w.Worksheets.Add(After:=w.Worksheets(Worksheets.Count)).Name = wsh.Cells(i, 3)
  If Not wsh.Cells(i + 1, 2) Like wsh.Cells(i, 2) Then
    w.SaveAs splitPath & wsh.Cells(i, 2)
    w.Close
    Set w = Workbooks.Add
  End If
Next i

End Sub

干杯

帕斯卡

http://multiskillz.tekcities.com

Answer 2

子 SplitSheetIntoCSV() 昏暗的工作表 调光范围 调暗标题作为范围 总行数变暗 使每个文件的行变暗只要 昏暗的起始行只要 暗淡端行只要 将文件计数器变暗为整数 将 csvFileName 变暗为字符串 将 csvFilePath 变暗为字符串 调暗输出范围作为范围

' Set worksheet and range
Set ws = ThisWorkbook.Sheets(1) ' Change to your sheet name or index
totalRows = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' Total rows in the sheet
Set header = ws.Rows(1) ' Assuming headers are in the first row

If totalRows < 2 Then
    MsgBox "Not enough rows to split!", vbExclamation
    Exit Sub
End If

' Calculate rows per file (excluding header row)
rowsPerFile = WorksheetFunction.RoundUp((totalRows - 1) / 4, 0)

' Loop to create CSV files
For fileCounter = 1 To 4
    startRow = (fileCounter - 1) * rowsPerFile + 2 ' Start row (skip header for all except first)
    endRow = Application.Min(fileCounter * rowsPerFile + 1, totalRows)
    
    ' Check if endRow is beyond the data
    If startRow > totalRows Then Exit For
    
    ' Create output range (include header)
    Set outputRange = Union(header, ws.Rows(startRow & ":" & endRow))
    
    ' Set the CSV file path
    csvFilePath = ThisWorkbook.Path & "\SplitFile_" & fileCounter & ".csv"
    
    ' Save the output range to CSV
    SaveRangeToCSV outputRange, csvFilePath
Next fileCounter

MsgBox "Split completed! Files saved in the same folder as the workbook.", vbInformation

结束子

Sub SaveRangeToCSV（rng 作为范围，filePath 作为字符串） 调暗 fs 作为对象 将 txtStream 变暗为对象 暗淡单元作为范围 Dim rowArray 作为变体 将 rowString 变暗为字符串 暗淡如久

' Create file system object
Set fs = CreateObject("Scripting.FileSystemObject")
Set txtStream = fs.CreateTextFile(filePath, True)

' Loop through rows in the range
For r = 1 To rng.Rows.Count
    rowArray = rng.Rows(r).Value
    rowString = ""
    
    ' Build the row as a comma-separated string
    For Each cell In rng.Rows(r).Cells
        rowString = rowString & cell.Value & ","
    Next cell
    
    ' Remove trailing comma and write to file
    rowString = Left(rowString, Len(rowString) - 1)
    txtStream.WriteLine rowString
Next r

' Close the text stream
txtStream.Close

结束子