ExcelVBA拆分_一簿一表_to_多簿一表

    '把当前表拆分：一簿一表_to_多簿一表或一簿一表_to_一簿多表
    '作者：哆哆
    '时间：2023-05
Sub yhd_ExcelVBA_2拆分_一簿一表_to_多簿一表()
    Dim title_row As Integer, RngCol As Range, split_Col As Integer
    Dim dic As Object, ThisSht As Worksheet, i As Long, pathstr As String, YN As Integer
    Dim newflag As Boolean, ThisWb As Workbook
    Set dic = CreateObject("scripting.dictionary")
    disAppSet (False)
    On Error Resume Next
    title_row = Application.InputBox(prompt:="请输入标题行数：", Type:=1)
    Set RngCol = Application.InputBox(prompt:="请选择拆分的依据列", Default:=Selection.Address, Title:="选择", Type:=8)
    If title_row = False Or RngCol = False Or title_row < 1 Then MsgBox "输入有误或选择空白区域，退了", 16, "哆哆提示": Exit Sub
    YN = MsgBox("【是】:拆分在工作簿" & Chr(13) & Chr(13) & "【否】:拆分并新建工作簿", vbYesNo, "是否拆分在本工作簿") 'vbYes=6,vbNo=7
    On Error GoTo 0                                            '以下恢复捕捉代码出现错误消息
    t = Timer
    newflag = YN - 6
    split_Col = RngCol.Column
    pathstr = ThisWorkbook.Path & "\拆分结果\"
    If Dir(pathstr, vbDirectory) = "" Then MkDir pathstr
    Set ThisSht = ActiveSheet
    With ThisSht
        lastrow = .Cells.Find("*", , , , 1, 2).Row
        For i = title_row + 1 To lastrow
            s = Trim(.Cells(i, split_Col))
            If s <> "" Then
                dic(s) = IIf(dic.exists(s), dic(s) & "_" & i, i)
            End If
        Next i
    End With
    For j = 0 To dic.Count - 1
        If newflag Then '0拆分在本工作簿1拆分并新建工作簿
            Set ThisWb = Workbooks.Add
        Else
            Set ThisWb = ThisWorkbook
        End If
        Set addSht = ThisWb.Worksheets.Add(After:=ThisWb.Worksheets(ThisWb.Worksheets.Count))
        With addSht
            ThisSht.Cells(1, 1).Resize(title_row, 1).EntireRow.Copy .Cells(1, 1)
            cc = VBA.Split(dic.items()(j), "_")
            Set ran = ThisSht.Rows(cc(0))
            For i = 1 To UBound(cc)
                If cc(i) <> "" Then
                    Set ran = Application.Union(ran, ThisSht.Rows(cc(i)))
                End If
            Next i
            ran.Copy
            .Cells(title_row + 1, 1).Select
            Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
            Selection.PasteSpecial Paste:=xlPasteFormats
            For Each shp In .Shapes
                shp.Delete
            Next shp
            .Cells(1, 1).Select
            .Name = dic.keys()(j)
        End With
        If newflag Then
            ThisWb.SaveAs pathstr & dic.keys()(j)
            ThisWb.Close True
        Else
            ThisWb.Save
        End If
        Set ThisWb = Nothing
    Next j
    disAppSet (True)
    MsgBox "拆分" & dic.Count & "个，用时：" & Format(Timer - t, "0.00秒")
    
End Sub
    '用法：disAppSet(true)开disAppSet(true)关
Sub disAppSet(flag As Boolean)
    With Application
        .ScreenUpdating = flag
        .DisplayAlerts = flag
        .AskToUpdateLinks = flag
        If flag Then
            .Calculation = xlCalculationAutomatic
        Else
            .Calculation = xlCalculationManual
        End If
    End With
End Sub