提取不同工作簿中的同一列数据

Sub demo()
    Dim ar, cr, Str As String, FilePath As String, i As Integer, j As Integer, n As Long
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    FilePath = ThisWorkbook.Path & ""           '获取当前工作簿路径
    Str = Dir(FilePath & "*.xls", vbNormal)      '把工作簿名赋值变量
    ReDim cr(1 To 60000, 1 To 18)                '重新定义数组大小
    Do While Str <> ""                           '遍历当前工作簿所在的文件夹
        If Not (Str = "要求.xlsm") Then          '判断工作簿名是否是要求，不是就执行下面代码
            Workbooks.Open FilePath & Str        '打开工作簿
            With Workbooks(2)
                ar = .Sheets(1).Range("A1").CurrentRegion     '把工作簿第一个工作表与A1单元格相连的单元格赋值给数组
                .Close savechange = True                      '关闭工作簿
            End With
            For i = 1 To UBound(ar)                           '循环数组
                n = n + 1
                For j = 1 To UBound(ar, 2)
                    cr(n, j) = ar(i, j)                        '循环把所有工作簿的第一个表的数据放入新的数组
                Next
            Next
        End If
        Str = Dir
    Loop
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Range("a1").Resize(n, 2) = cr                                 '把新数组写入当前工作簿的第一个表的a1单元格为顶点的区域
End Sub