将确定的一系列电子表格划分为带有新名称的新工作簿

Question

我一直在尝试根据工作簿中确定的工作表将工作簿分为单独的工作簿的方法。

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

我想将工作表a通过c分开为一个名为" a tht t c"的新工作簿。

d通过我将进入一个名为" d ta i i"的新工作簿。

等...

我的想法是首先插入一个工作表，该工作表中的名称将成为新的工作簿，并且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

结束sub

Answer 1

以下代码假定您在包含宏的工作簿中具有控制表(名为" split参数"(，并且在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