多工作簿数据合并

arrEH

工作簿合并问题，见附件说明示例。谢谢老师~！

乐乐2006201505

Sub test合并排序删重()
    Dim lr&, i%, j%, j1%, m%, t&
    Dim arr, brr, crr(1 To 30000, 1 To 10)
    Dim sh As Worksheet
    Dim mypath$ ', myname$
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    mypath = ThisWorkbook.Path & "\"
    lr = ThisWorkbook.Sheets(1).Range("x1").End(4).Row
    arr = ThisWorkbook.Sheets(1).Range("x1:x" & lr)
    For i = 1 To UBound(arr)
        Set sh = GetObject(mypath & "集合\" & arr(i, 1) & ".xlsm").Sheets(2)
        brr = sh.UsedRange
        Workbooks(arr(i, 1) & ".xlsm").Close False
        For j = 3 To UBound(brr)
            m = m + 1
            For j1 = 1 To 10
                crr(m, j1) = "'" & Format(brr(j, j1), "000")
            Next
        Next
        Set sh = Nothing
    Next
    With ThisWorkbook.Sheets(1)
        .Range("a3:j30000").ClearContents
        .[a3].Resize(m, UBound(crr, 2)).Value = crr
        For c = 1 To 10
             '排序
            .Range(.Cells(3, c), .Cells(30000, c)).Select
            .Sort.SortFields.Clear
            .Sort.SortFields.Add2 Key:=.Range(.Cells(3, c), .Cells(30000, c)), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Range(Cells(3, c), Cells(30000, c))
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            '删重
            .Range(.Cells(3, c), .Cells(30000, c)).RemoveDuplicates Columns:=1, Header:=xlNo
        Next
        .Range("a3").Select
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "汇总完成！汇总了：" & lr & "个工作表；共有：" & m & "行数据。" & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
End Sub

arrEH

乐乐2006201505 发表于 2019-2-16 21:03
Sub test合并排序删重()
    Dim lr&, i%, j%, j1%, m%, t&
    Dim arr, brr, crr(1 To 30000, 1 To 10) ...

你好老师，运行代码后显示：下标越界或者溢出哦

乐乐2006201505

上传出错文件。

arrEH

乐乐2006201505 发表于 2019-2-16 21:38
上传出错文件。

运行代码出现：下标越界，再后就显示溢出。麻烦老师看下。

jjmysjg

留个记号，谢谢

arrEH

再顶一下。。

乐乐2006201505

arrEH 发表于 2019-2-17 07:56
再顶一下。。

没问题啊！

arrEH

乐乐2006201505 发表于 2019-2-17 08:16
没问题啊！

老师，可在我电脑上一运行，就出现这样哦

arrEH

乐乐2006201505 发表于 2019-2-17 08:16
没问题啊！

每运行一次代码，会出现不同的提示，代码运行不了哦。