exl合并的问题,就是将多个exl表合并成一个exl表现在是有1个exl,分别给10个人做统计,然后他们会在后面添加上自己的数据（文字）,10个人的编辑区域不会重合,然后得到10个exl,需要将这10个exl再

exl合并的问题,就是将多个exl表合并成一个exl表现在是有1个exl,分别给10个人做统计,然后他们会在后面添加上自己的数据（文字）,10个人的编辑区域不会重合,然后得到10个exl,需要将这10个exl再
exl合并的问题,就是将多个exl表合并成一个exl表
现在是有1个exl,分别给10个人做统计,然后他们会在后面添加上自己的数据（文字）,10个人的编辑区域不会重合,然后得到10个exl,需要将这10个exl再合成一个exl该怎么做?

exl合并的问题,就是将多个exl表合并成一个exl表现在是有1个exl,分别给10个人做统计,然后他们会在后面添加上自己的数据（文字）,10个人的编辑区域不会重合,然后得到10个exl,需要将这10个exl再
Option Explicit
Sub 多簿合并()
Dim Wb As Workbook
Dim bName As Variant
Dim tempName As String, i As Integer, DataRow As Long, j As Long, k As Long, m As Integer
Dim MyMtrx() As String, MainListRow As Long
Dim ErrbName As String
bName = Array("城东公客", "登封", "港区", "巩义", "郊区", "金水公客", "上街", "网建", "未分区", "西区公客") '分表名称
Range("T2:IV" & Rows.Count).Clear '清除T以后全部列
MainListRow = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1 '获取主表最后一行行号
Application.ScreenUpdating = False '关闭屏幕刷新
For i = 0 To UBound(bName)
    tempName = ThisWorkbook.Path & "\" & bName(i) & ".xls" '分表路径名称
    On Error GoTo CheckError '开启错误捕获
    Set Wb = GetObject(tempName) '获取分表
    On Error GoTo 0 '关闭错误捕获
    With Wb.Sheets(1)
        DataRow = .UsedRange.Rows.Count + .UsedRange.Row - 1 '获取分表最后一行行号
        k = 0 '初始化
        For j = 1 To DataRow
            If .Range("T" & j) <> "" Then '把分表中T列非空白的行的关键信息、备注信息保存到数组,E、F、I、T列是关键信息,T是备注信息
                k = k + 1
                ReDim Preserve MyMtrx(1 To 4, 1 To k)
                MyMtrx(1, k) = .Range("E" & j)
                MyMtrx(2, k) = .Range("F" & j)
                MyMtrx(3, k) = .Range("I" & j)
                MyMtrx(4, k) = .Range("T" & j)
            End If
        Next j
    End With
    Wb.Close False '关闭分表
    Set Wb = Nothing '清除分表变量
    For j = 2 To UBound(MyMtrx, 2) '通过循环输出备注信息,1为表头,从2开始
        For k = 2 To MainListRow
            If Range("E" & k).Text = MyMtrx(1, j) And Range("F" & k).Text = MyMtrx(2, j) And Range("I" & k).Text = MyMtrx(3, j) Then '关键信息全部吻合
                For m = Range("T1").Column To Range("IV1").Column '通过循环找空白位置
                    If Cells(k, m) = "" Then '找到空白位置
                        Cells(k, m) = MyMtrx(4, j) '输出
                        Exit For
                    End If
                Next m
                Exit For
            End If
        Next k
        If k > MainListRow Then
            MsgBox "分表-" & bName(i) & "-有以下信息无法在主表中匹配:" & vbCrLf & vbCrLf & MyMtrx(1, j) & vbCrLf & MyMtrx(2, j) & vbCrLf & MyMtrx(3, j)
            If MsgBox("是否结束本程序?", vbYesNo, "有异常") = vbYes Then
                Application.ScreenUpdating = True
                Exit Sub
            End If
        End If
    Next j
    Erase MyMtrx '清除数组
Pass:
Next i '处理下一个分表
If Len(ErrbName) > 0 Then
    MsgBox "没有找到以下工作簿：" & vbCrLf & ErrbName
End If
Application.ScreenUpdating = True
Exit Sub
CheckError:
ErrbName = ErrbName & vbCrLf & bName(i)  '记录错误工作簿名
Resume Pass
End Sub