VBA_彙總不同工作表相同格式資料

如果使用Power Query 該有的欄位都有，但不同檔的欄位排列不一樣的話(A檔 甲乙丙,B檔 丙乙甲)，Power Query可以自動排列，我還是比較喜歡用Power Query。

彙總個工作表資料 

Sub A0_彙整資料()

    '2022/1/2 22:00  22:30完成

    Application.ScreenUpdating = False

    

    Dim D_項目, D_附件, D_工作表, Sh_項目 As Worksheet, sh_附件 As Worksheet

    

    Set D_項目 = CreateObject("scripting.dictionary")

    Set D_附件 = CreateObject("scripting.dictionary")

    Set D_工作表 = CreateObject("scripting.dictionary")

    

    

    For i = 1 To Sheets.Count

        D_工作表(Sheets(i).Name) = i

    Next

    If D_工作表.exists("項目彙總") = False Then

        Sheets.Add.Name = "項目彙總"

    End If

    If D_工作表.exists("附件彙總") = False Then

        Sheets.Add.Name = "附件彙總"

    End If

    Set Sh_項目 = Sheets("項目彙總")

    Set sh_附件 = Sheets("附件彙總")

    'On Error Resume Next

    For i_sh = 1 To Sheets.Count

        With Sheets(i_sh)

            If .Cells(9, 2) = "稽核項目" Then

                br = .Cells.Find("稽核項目", LookIn:=xlValues).Row

                bc = .Cells.Find("稽核項目", LookIn:=xlValues).Column

                lr = .Cells(br, bc).Offset(, 1).End(xlDown).Row

                For i = br To lr

                    in_項目 = .Cells(i, bc)

                    in_範圍 = .Cells(i, bc + 1)

                    in_單位 = .Cells(i, bc + 2)

                    in_日期 = .Cells(i, bc + 3)

                    in_工作表 = Sheets(i_sh).Name

                    

                    D_項目(in_工作表 & i) = Array(in_工作表, in_項目, in_範圍, in_單位, in_日期)

                Next

            ElseIf .Cells(6, 2) = "編號" Then

                br = .Cells.Find("編號", LookIn:=xlValues).Row

                bc = .Cells.Find("編號", LookIn:=xlValues).Column

                lr = .Cells(br, bc).Offset(, 1).End(xlDown).Row

                For i = br To lr

                    in_編號 = .Cells(i, bc)

                    in_部門 = .Cells(i, bc + 1)

                    in_文件 = .Cells(i, bc + 2)

                    in_工作表 = Sheets(i_sh).Name

                    

                    D_附件(in_工作表 & i) = Array(in_工作表, in_編號, in_部門, in_文件)

                Next

            End If

        End With

    Next

    With Sh_項目

        .Cells.Delete

        

        .Range("A2").Resize(D_項目.Count, 5) = Application.Transpose(Application.Transpose(D_項目.items))

        

    End With

    With sh_附件

        .Cells.Delete

        

        .Range("A2").Resize(D_附件.Count, 4) = Application.Transpose(Application.Transpose(D_附件.items))

        

    End With

End Sub