VBA 字典 多表不同标题顺序 使用字典定位来合并工作表真的很简单

Sub GetData(control As IRibbonControl)
    Call Dic_JoinSht
End Sub


Sub Dic_JoinSht()
    Dim Dic As Object
    Dim Sht As Worksheet
    Dim iRow&, iCol&, intX&, intY&, y&
    Dim aData, aRes
    On Error Resume Next
    Set Dic = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False '取消闪屏弹窗
    Application.DisplayAlerts = False
    Worksheets("汇总表").Delete '删除汇总表
    With Sheets.Add(after:=Sheets(Sheets.Count)) '新建一个工作表,并且命名为汇总表
        .Name = "汇总表"
    End With
    With Worksheets("汇总表")
        .Cells(1, 1) = "工作表名称"
        iCol = 1 '初始化计数器
        For Each Sht In Worksheets '遍历循环工作表
            If Sht.Name <> .Name Then
                If Not IsEmpty(Sht.UsedRange) Then '判断是否空表
                    If Sht.AutoFilterMode = True Then Sht.Cells.AutoFilter '取消筛选
                    aData = Sht.Range("A1").CurrentRegion '获取数据源
                    ReDim aRes(1 To UBound(aData) - 1, 1 To iCol) '定义结果数组大小
                    For intY = 1 To UBound(aData, 2)
                        If Not Dic.exists(aData(1, intY)) Then '判断标题关键字是否存在字典
                            iCol = iCol + 1
                            Dic(aData(1, intY)) = iCol '标题为关键字,所在结果数组列位置为条目 存入字典
                            If iCol > UBound(aRes, 2) Then ReDim Preserve aRes(1 To UBound(aRes), 1 To iCol)
                            '判断列位置是否大于结果数据列维度,符合条件使用ReDim Preserve调整结果数组的大小
                        End If
                        y = Dic(aData(1, intY)) '标题所在结果数组中的列位置
                        For intX = 2 To UBound(aData) '遍历行
                            aRes(intX - 1, y) = aData(intX, intY) '数据元素存入结果数组
                        Next
                    Next
                    For intX = 1 To UBound(aRes)
                        aRes(intX, 1) = Sht.Name '存入工作表名称
                    Next
                End If
                .Cells(.Cells(Rows.Count, 1).End(3).Row + 1, 1).Resize(UBound(aRes), UBound(aRes, 2)) = aRes '在数据最后的行位置输入结果数组内容
            End If
        Next
        .Cells(1, 2).Resize(, Dic.Count) = Dic.keys '输出标题
        .UsedRange.Borders.LineStyle = 1 '添加边框
        .Columns.AutoFit '自适应列宽
        .Cells(2, 1).Select
        ActiveWindow.FreezePanes = True '冻结窗格
        ActiveWindow.DisplayGridlines = False
    End With
    Application.DisplayAlerts = True '恢复系统设置
    Application.ScreenUpdating = True '取消网格线
    Set Dic = Nothing '释放
End Sub