工作簿合并代码纠错

金风2014

测试时倒数第五项代码出错，请哪位好心人帮忙看看原因，谢谢

要达到的效果：原始数据文件夹中的表一和表二标题名称相同，但列顺序不一致，请帮忙按总表标题顺序合并提取表一、表二数据。另外表一、表二的工作簿名称是不固定的，文件夹名称是固定的。

已有代码：
Private Sub CommandButton1_Click()
Dim Wbk As Workbook, Sht As Worksheet
Dim Arr, Ar, Brr()
Dim MyPath$, Fn, x&
Set Db = CreateObject("scripting.dictionary")
MyPath = ThisWorkbook.Path & "\"
Fn = Dir(MyPath & "*.xl*")
Ar = ActiveWorkbook.Sheets("sheet1").[a1].CurrentRegion
For i = 1 To UBound(Ar, 2)
  Db(Ar(1, i)) = i
  Next i
  ReDim Brr(1 To 1000, 1 To 4)
  Application.ScreenUpdating = False
  Do While Fn <> ""
    If Fn <> ThisWorkbook.Name Then
    Set Wbk = Workbooks.Open(MyPath & Fn)
     With Wbk.Sheets("sheet1")
     Arr = .[a1].CurrentRegion
     For i = 2 To UBound(Arr)
     x = x + 1
     For j = 1 To UBound(Arr, 2)
     If Db.exists(Arr(1, j)) Then
     Brr(x, Db(Arr(1, j))) = Arr(i, j)
       End If
       Next j
       Next i
       End With
       Application.DisplayAlerts = False
       Wbk.Close False
       Application.DisplayAlerts = True
       End If
       Fn = Dir
       Loop
       With ActiveSheet
       .Range("a2:d" & .Rows.Count).ClearContents
       .[a2].Resize(x, 4) = Brr
       End With
       Set Db = Nothing
       Application.ScreenUpdating = True
       End Sub

lsc900707

Private Sub CommandButton1_Click()
Dim Wbk As Workbook, Sht As Worksheet
Dim Arr, Ar, Brr()
Dim MyPath$, Fn, x&
Set Db = CreateObject("scripting.dictionary")
MyPath = ThisWorkbook.Path & "\原始数据\"
Fn = Dir(MyPath & "*.xl*")
Ar = ActiveWorkbook.Sheets("sheet1").[a1].CurrentRegion
For i = 1 To UBound(Ar, 2)
  Db(Ar(1, i)) = i
  Next i
  ReDim Brr(1 To 1000, 1 To 4)
  Application.ScreenUpdating = False
  Do While Fn <> ""
    If Fn <> ThisWorkbook.Name Then
    Set Wbk = Workbooks.Open(MyPath & Fn)
     With Wbk.Sheets("sheet1")
     Arr = .[a1].CurrentRegion
     For i = 2 To UBound(Arr)
     x = x + 1
     For j = 1 To UBound(Arr, 2)
     If Db.exists(Arr(1, j)) Then
     Brr(x, Db(Arr(1, j))) = Arr(i, j)
       End If
       Next j
       Next i
       End With
       Application.DisplayAlerts = False
       Wbk.Close False
       Application.DisplayAlerts = True
       End If
       Fn = Dir
       Loop
       With ActiveSheet
       .Range("a2:d" & .Rows.Count).ClearContents
       .[a2].Resize(x, 4) = Brr
       End With
       Set Db = Nothing
       Application.ScreenUpdating = True
End Sub

lsc900707

参考附件：

金风2014

测试可用,谢谢各位帮忙

金风2014

朱荣兴 发表于 2018-8-8 21:05
典型的字典匹配的案例呀。

今年刚开始接触VBA,字典还不会用,工作需要只能先来找各位帮忙应急.