Question

我一直试图想出一种方法，根据工作簿中已识别的工作表将工作簿拆分为单独的工作簿。

例如：假设我有一个字母表中每个字母的工作表。

我想将工作表A到C拆分成一个名为“A到C”的新工作簿。

我将进入一个名为“D through I”的新工作簿。

等...

我的想法是首先插入一个工作表，在A列中命名它将成为新工作簿，列b通过尽可能多的列，将工作表的名称复制到新工作簿中。

有没有人知道如何为此制作宏？我已经尝试过但是没有成功。

谢谢！

我在那里发现了这个宏。有人认为可以修改它吗？

Sub Test()
Dim Sh As Worksheet
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Dim WB As Workbook
Application.ScreenUpdating = False

Set Sh = Worksheets("Sheet1")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
On Error Resume Next
For Each c In Rng
    List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("A1:H" & Sh.Range("A65536").End(xlUp).Row)
For Each Item In List
    Set WB = Workbooks.Add
    Rng.AutoFilter Field:=1, Criteria1:=Item
    Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A1")
    Rng.AutoFilter
    With WB
        .SaveAs ThisWorkbook.Path & "\" & Item & ".xls"
        .Close
    End With
Next Item
Sh.Activate
Application.ScreenUpdating = True

End Sub

Answer 1

以下代码假定您在包含宏的工作簿中有控制表（命名为＆＃34;拆分参数＆＃34;），并且在A列中列出了所需的文件名，以及您希望的工作表复制到该文件（来自ActiveWorkbook，可能是，也可能不是，包含宏的那个）列在B，C等列中。第1行被假定为标题，因此被忽略。

Sub SplitBook()
    Dim lastRow As Long
    Dim LastColumn As Long
    Dim srcWB As Workbook
    Dim newWB As Workbook
    Dim i As Long
    Dim c As Long
    Dim XPath As String
    Dim newName As String
    Dim sheetName As String

    Application.ScreenUpdating =  False
    Application.DisplayAlerts =  False
    Set srcWB = ActiveWorkbook
    XPath = srcWB.Path
    With ThisWorkbook.Worksheets("Split Parameters")
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lastRow
            'Take the first worksheet and create a new workbook
            sheetName = .Cells(i, "B").Value
            srcWB.Sheets(sheetName).Copy
            Set newWB = ActiveWorkbook
            'Now process all the other sheets that need to go into this workbook
            LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
            For c = 3 To LastColumn
                sheetName = .Cells(i, c).Value
                srcWB.Sheets(sheetname).Copy After:=newWB.Sheets(newWb.Sheets.Count)
            Next
            'Save the new workbook
            newName = .Cells(i, "A").Value
            newWB.SaveAs Filename:=xPath & "\" & newName & ".xls", FileFormat:=xlExcel8
            newWB.Close False
        Next
    End With
    Application.DisplayAlerts =  True
    Application.ScreenUpdating =  True
End Sub

将已识别的电子表格范围拆分为新工作簿，并使用新名称

1 个答案: