多工作表合并求vba高手

笨鸟飞不高

多工作表合并求vba高手.zip (50.68 KB, 下载次数: 12)

2018-10-20 13:06 上传

点击文件名下载附件

要求把文件夹中多个工作簿中的多个工作表合并到一张工作表中
附件中的文件夹1中汇总代码是论坛大神zhaogang1960写的，如果分表格式变成文件夹2中的这样，汇总代码应该怎样修改？求教论坛高手帮忙，谢谢！

abc123281

Sub Macro1()
    Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xls")
    [a1].CurrentRegion.Offset(2).Clear
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                For Each sht In .Sheets
                    If sht.[a1].CurrentRegion.Rows.Count > 1 Then
                        lr = sh.[a1].CurrentRegion.Rows.Count + 1
                        r = sht.[a1].CurrentRegion.Rows.Count - 1
                        sh.Cells(lr, 1).Resize(r) = MyName
                        sh.Cells(lr, 2).Resize(r) = sht.Name
                        sht.[a1].CurrentRegion.Offset(1).Copy sh.Cells(lr, 3)
                    End If
                Next
                .Close False
            End With
        End If
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

lsc900707

我在测试时数据汇总不全，用数组改写了一个：
Sub Macro1()
    Dim brr(1 To 99999, 1 To 17)
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            With GetObject(p & f)
                For Each sht In .Sheets
                    arr = sht.[a1].CurrentRegion
                    For i = 2 To UBound(arr)
                        m = m + 1
                        brr(m, 1) = Split(f, ".")(0)
                        brr(m, 2) = sht.Name
                        For j = 3 To 17
                            brr(m, j) = arr(i, j - 2)
                        Next
                    Next
                Next
                .Close False
            End With
        End If
        f = Dir
    Loop
    If m Then
        [a2].CurrentRegion.Offset(1).ClearContents
        [a3].Resize(m, 17) = brr
    End If
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

lsc900707

测试参考附件：

10307951261

留个脚印学习