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

哆哆Excel

发布于 2023-09-09 02:50:30

26800

代码可运行

文章被收录于专栏：哆哆Excel哆哆Excel

运行总次数：0

代码可运行

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

=====start====

1.Excel按单位拆分成不同工作表

2.Excel技巧篇-利用数据透视表按单位分类拆分工作表

=====end====

【问题】

在本工作簿中把当前的工作表，按“省份”拆分成不同的工作表，拆分出来的表生成在本工作簿

【思路】

1.先弹出对话框，输入标题行数2.再弹出对话框，输入你要拆分的列在那一列，选择那列3.用字典，对所在列进行去重4.再生成key值工作表，5.复制标题，复制,等于key值的行，先复制数据与公式，再复制格式

【代码】

    '把当前表拆分：一簿一表_to_一簿多表
    '作者：哆哆
    '时间：2023-05
Sub yhd_ExcelVBA_3拆分_一簿一表_to_一簿多表()
    Dim title_row As Integer, RngCol As Range, split_Col As Integer
    Dim dic As Object, ThisSht As Worksheet, i As Long
    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
    On Error GoTo 0                                            '以下恢复捕捉代码出现错误消息
    t = Timer
    split_Col = RngCol.Column
    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
'    With Worksheets("Sheet2")
'        For k = 1 To dic.Count
'            .Cells(k, 1) = dic.keys()(k - 1)
'            .Cells(k, 2) = dic.items()(k - 1)
'        Next k
'    End With
    For j = 0 To dic.Count - 1
        Set addSht = Worksheets.Add(After:=Worksheets(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
    Next j
    MsgBox "拆分" & dic.Count & "个，用时：" & Format(Timer - t, "0.00秒")
    disAppSet (True)
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