37，多文件夹多工作簿多工作表汇总(searfile)

'37，多文件夹多工作簿多工作表汇总(searfile)

'2014-8-29

'http://club./thread-1148457-1-1.html

Public Brr(), r&

    Sub lqxs()

        Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet

        Dim i&, n&, d, k, t, aa, nm$, j&, b

        Application.ScreenUpdating = False

        Set d = CreateObject("Scripting.Dictionary")

        myPath = ThisWorkbook.PATH & "\原始文件\"

        Call searfile(myPath, ".xlsx")

        For i = 1 To UBound(Brr, 2)

            aa = Split(Brr(1, i), "\")

            nm = aa(UBound(aa) - 1)

            d(nm) = d(nm) & Brr(1, i) & "|" & Brr(2, i) & ","

        Next

        k = d.keys: t = d.items

        For i = 0 To UBound(k)

            t(i) = Left(t(i), Len(t(i)) - 1)

            If InStr(t(i), ",") Then

                aa = Split(t(i), ",")

                Application.SheetsInNewWorkbook = UBound(aa) + 1

                Workbooks.Add  '新工作簿的表格数量

                Set wb = ActiveWorkbook: n = 0

                For j = 0 To UBound(aa)

                    b = Split(aa(j), "|")

                    With GetObject(b(0) & b(1))

                        For Each sh In .Sheets

                            Arr = sh.Range("a1").CurrentRegion

                            n = n + 1

                            With wb.Sheets(n)

                                .[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr

                                .Name = sh.Name

                            End With

                        Next

                        .Close False

                    End With

                Next

            Else

                Application.SheetsInNewWorkbook = 1

                Workbooks.Add

                Set wb = ActiveWorkbook: n = 0

                b = Split(t(i), "|")

                With GetObject(b(0) & b(1))

                    For Each sh In .Sheets

                        Arr = sh.Range("a1").CurrentRegion

                        n = n + 1

                        With wb.Sheets(n)

                            .[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr

                            .Name = sh.Name

                        End With

                    Next

                    .Close False

                End With

            End If

            wb.SaveAs ThisWorkbook.PATH & "\" & k(i) & ".xlsx"

            wb.Close False

        Next

        Application.ScreenUpdating = True

    End Sub

   

    '2014-12-26

    'http://club./thread-1175063-1-1.html

    Sub lqxs()

        Dim Arr, myPath$, myName$, d, k, t

        Dim wb As Workbook, nm, aa, i&, j&

        Set d = CreateObject("Scripting.Dictionary")

        Application.ScreenUpdating = False

        myPath = ThisWorkbook.PATH & "\明细\"

        Call searfile(myPath, ".xls")

        For i = 1 To UBound(Brr, 2)

            nm = Split(Brr(2, i), "（")

            d(nm(0)) = d(nm(0)) & Replace(nm(1), "）.xls", "") & ","

        Next

        k = d.keys: t = d.items

        For i = 0 To UBound(k)

            t(i) = Left(t(i), Len(t(i)) - 1)

            If InStr(t(i), ",") Then

                aa = Split(t(i), ",")

                Application.SheetsInNewWorkbook = UBound(aa) + 1 '新增加工作簿的工作表的个数

                Workbooks.Add

                Set wb = ActiveWorkbook

                For j = 0 To UBound(aa)

                    wb.Sheets(j + 1).Name = aa(j)

                    With GetObject(myPath & k(i) & "（" & aa(j) & "）.xls")

                        Arr = .Sheets(1).UsedRange

                        .Close False

                    End With

                    wb.Sheets(j + 1).[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr

                Next

            Else

                Workbooks.Add

                Set wb = ActiveWorkbook

                wb.Sheets(1).Name = t(i)

                With GetObject(myPath & k(i) & "（" & t(i) & "）.xls")

                    Arr = .Sheets(1).UsedRange

                    .Close False

                End With

                wb.Sheets(1).[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr

            End If

            wb.SaveAs ThisWorkbook.PATH & "\合并效果\" & k(i) & "1.xls"

            wb.Close

        Next

        Application.ScreenUpdating = True

    End Sub