继续求助：多薄多表合并

lyb65830

新手求助：
找到的模版跟我的需求有点差别，不会改，求修改~
需求
1.在汇总表内新建A、B、C三个工作表，将本文件夹内A、B、C三个文件夹内的所有工作簿工作表复制到对应的工作表内（首行有标题）
2.再次运行只是将新增的工作薄工作表复制过来，尽量避免每次都全部复制
3.汇总表内可以用数据透视表统计A\B\C三张工作表
4.事例中建了3个文件夹，实际需要8个左右

工作薄 工作表都是以日期命名的，一个工作薄一个月的数据大概1M不到，12个月按6个文件算大概70M
这样的数据量到年底每次都跑一遍会不会影响速度？
如果不影响速度，第二条可以忽略

opiona

再次运行只是将新增的工作薄工作表复制过来
如何识别：那些事新增的工作簿

182197315

Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num, ini As Long
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
ini = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
If ini = 0 Then
Wb.Sheets(1).Range(Wb.Sheets(1).Cells(1, 1), Wb.Sheets(1).Cells(1, Wb.Sheets(1).UsedRange.Columns.Count)).Copy .Cells(1, 1)
ini = 1
End If
For G = 1 To Sheets.Count
Wb.Sheets(G).Range(Wb.Sheets(G).Cells(2, 1), Wb.Sheets(G).Cells(Wb.Sheets(G).UsedRange.Rows.Count, Wb.Sheets(G).UsedRange.Columns.Count)).Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

lyb65830

工作薄 工作表都是以日期命名的，一个工作薄一个月的数据大概1M不到，12个月按6个文件算大概70M
这样的数据量到年底每次都跑一遍会不会影响速度？
如果不影响速度，第二条可以忽略

lyb65830

182197315 发表于 2016-5-21 11:42
Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As  ...

只能合并文件夹内的工作薄，不能分别复制子文件夹下的工作薄

lyb65830

继续求助~~~

182197315

Sub 汇总子文件的所有表格()
    [A2:F600].ClearContents
    Dim cPath$, s%, x%, cDir$, cFile$, Arr(1 To 10), wb As Workbook
    Dim nRow%, m%, Brr(), Crr()
    cPath = ThisWorkbook.Path & "\"
    cDir = Dir(cPath & "*", 16)
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    For Each wb In Workbooks
        If wb.Name <> ThisWorkbook.Name Then wb.Close
    Next
    Do While cDir <> ""
        If Not cDir Like ".*" Then
            If GetAttr(cPath & cDir) = 16 Then
                s = s + 1
                Arr(s) = cDir
            End If
        End If
        cDir = Dir
    Loop
    For i = 1 To s
        cFile = Dir(cPath & Arr(i) & "\*.xls*")
        Do While cFile <> ""
            Set wb = Workbooks.Open(cPath & Arr(i) & "\" & cFile)
                For x = 1 To wb.Sheets.Count
                    With wb.Sheets(x)
                        nRow = .Range("a65536").End(xlUp).Row
                        Brr = .Range("a2:f" & nRow).Value
                        nr2 = Me.Range("a65536").End(xlUp).Row + 1
                        Me.Range("a" & nr2).Resize(nRow - 1, 6).Value = Brr
                    End With
                Next
            wb.Close
            cFile = Dir
        Loop
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub


Sub 汇总指定文件夹里的表格()
    [A2:F600].ClearContents
    Dim cPath$, cFile$, wb As Workbook
    Dim nRow%, m%, Brr()
    cPath = ThisWorkbook.Path & "\A\"
    cFile = Dir(cPath & "*.xls*")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Do While cFile <> ""
        Set wb = Workbooks.Open(cPath & cFile)
            For x = 1 To wb.Sheets.Count
                With wb.Sheets(x)
                    nRow = .Range("a65536").End(xlUp).Row
                    Brr = .Range("a2:f" & nRow).Value
                    nr2 = Me.Range("a65536").End(xlUp).Row + 1
                    Me.Range("a" & nr2).Resize(nRow - 1, 6).Value = Brr
                End With
            Next
        wb.Close
        cFile = Dir
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

182197315

终于搞定了，请看附件。

lyb65830

182197315 发表于 2016-5-22 19:40
终于搞定了，请看附件。

谢谢  模版解决了两个问题
总表汇总所有子文件夹文件；分表汇总指定子文件夹的文件；
虽然我的本意是一键将几个子文件夹的文件分别汇总到对应的工作表内，总表用数据透视表来统计分析
就这样的功能已经可以满足我使用了，谢谢~~

LMY123

常规法，多薄多表合并，含文件夹