【求助大神】同一工作簿中多个工作表（格式不同）按指定字段拆分为多个工作簿

yff1019

将一个工作簿中的2个以上工作表，按照“VP”一列字段拆分为不同工作簿并以对应VP命名，拆分出来。拆分后的每个工作簿中包括原始工作簿中含该字段的所有工作表，拆分后的每个工作簿都以被拆分的那列来命名，如果可以的话，希望能以“VP+自定义内容”：比如"VP+项目计划” 来命名。 请各位大神帮忙，万分感谢！

liulang0808

http://club.excelhome.net/thread-1385473-1-1.html
字典的案例，楼主可以参考下

orr89

Sub 宏3()
    Dim dic
    Set dic = CreateObject("scripting.dictionary")
    Set dic1 = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1").CurrentRegion
    brr = Sheet2.Range("a1").CurrentRegion
    For a = 2 To UBound(arr)
        If Not dic.exists(arr(a, 5)) Then
            dic(arr(a, 5)) = arr(a, 5) & "_" & arr(a, 2)
        End If
    Next
    For a = 2 To UBound(brr)
        If Not dic1.exists(brr(a, 4)) Then
            dic1(brr(a, 4)) = brr(a, 4) & "_" & brr(a, 1)
        End If
    Next
    For a = 1 To dic.Count
        ActiveSheet.Range("$A$1:$E$" & UBound(arr)).AutoFilter Field:=5, Criteria1:=dic.keys()(a - 1)
        Sheets("小额").Select
        ActiveSheet.Range("$A$1:$D$" & UBound(brr)).AutoFilter Field:=4, Criteria1:=dic.keys()(a - 1)
        Workbooks.Add
        ChDir "C:\Users\Administrator\Desktop"
        ActiveWorkbook.SaveAs Filename:="C:\Users\Administrator\Desktop\" & dic.items()(a - 1) & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        Windows("模板.xls").Activate
        Range("A1:D" & Sheet2.[a60000].End(xlUp).Row).Copy
        Windows(dic.items()(a - 1) & ".xlsx").Activate
        Sheets("Sheet2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Sheets("Sheet2").Select
        Sheets("Sheet2").Name = "小额"
        Sheets("Sheet1").Select
        Sheets("Sheet1").Name = "大额"
        Windows("模板.xls").Activate
        Sheets("大额").Select
        Range("A1:E" & Sheet1.[a60000].End(xlUp).Row).Copy
        Windows(dic.items()(a - 1) & ".xlsx").Activate
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        ActiveWorkbook.Save
        ActiveWindow.Close
    Next
End Sub

3190496160

Sub chaifen()
Application.ScreenUpdating = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
    r = sh.Rows(1).Find("VP", , , 1).Column
    ar = sh.[a1].CurrentRegion
    For i = 2 To UBound(ar)
        If Trim(ar(i, r)) <> "" Then
            d(Trim(ar(i, r))) = ""
        End If
    Next i
Next sh
Dim rng As Range
Application.SheetsInNewWorkbook = 1
For Each k In d.keys
    Set wb = Workbooks.Add
    For Each sh In ThisWorkbook.Worksheets
        r = sh.Rows(1).Find("VP", , , 1).Column
        ar = sh.[a1].CurrentRegion
       sh.Copy after:=wb.Worksheets(wb.Worksheets.Count)
       With wb.Worksheets(wb.Worksheets.Count)
            For i = 2 To UBound(ar)
                 If Trim(ar(i, r)) <> k Then
                     If rng Is Nothing Then
                         Set rng = .Rows(i)
                      Else
                         Set rng = Union(rng, .Rows(i))
                      End If
                End If
            Next i
            If Not rng Is Nothing Then rng.Delete
            Set rng = Nothing
            
        End With
    Next sh
    Application.DisplayAlerts = False
    wb.Worksheets(1).Delete
    Application.DisplayAlerts = True
wb.SaveAs Filename:=ThisWorkbook.Path & "\拆分后\" & k & "-计划项目"
wb.Close
Next k
Application.ScreenUpdating = True
End Sub

3190496160

完全保留原工作表结构拆分
模板.rar (14.23 KB, 下载次数: 222)

2020-3-7 17:16 上传

点击文件名下载附件

yff1019

3190496160 发表于 2020-3-7 17:16
完全保留原工作表结构拆分

太感谢了，完全是我要的结果！谢谢分享！

yff1019

liulang0808 发表于 2020-3-7 08:28
http://club.excelhome.net/thread-1385473-1-1.html
字典的案例，楼主可以参考下

谢谢，这个集合对工作中的其他的问题很有帮助！

qsxcvbji

3190496160 发表于 2020-3-7 17:15
Sub chaifen()
Application.ScreenUpdating = False
Dim d As Object

模板不一样，更改了find里面的VP改成我需要的关键字和文件后缀名后，运行提示91，哪里有问题，谢谢大佬

3190496160

qsxcvbji 发表于 2021-12-3 14:21
模板不一样，更改了find里面的VP改成我需要的关键字和文件后缀名后，运行提示91，哪里有问题，谢谢大佬

具体原因很多，见不到文件，爱莫能助

qsxcvbji

qsxcvbji 发表于 2021-12-3 14:21
模板不一样，更改了find里面的VP改成我需要的关键字和文件后缀名后，运行提示91，哪里有问题，谢谢大佬

类似于这种的，按照省份名称分别拆分同一工作簿下的明细，并以省份名称命名。辛苦了，非常感谢。