多文件夹多工作簿指定工作表汇总

mmwwdd

Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Set d = CreateObject("scripting.dictionary")
Dim MyPath$, MyName
MyPath = ThisWorkbook.Path & "\2017年\"
MyName = Dir(MyPath & "*.xls*")
With Sheets("2017")
  For i = 2 To 7
    d(.Cells(i, 1).Value) = i
  Next
End With
Do While MyName <> ""
  Set wb = GetObject(MyPath & MyName)
  
      With wb.Sheets("水果")
      r = .Cells(.Rows.Count, 1).End(3).Row
      brr = .Range("B1:c" & r)
      ls = Len(brr(1, 1))
      ls = Left(brr(1, 1), Len(brr(1, 1)) - 1)
      For j = 1 To UBound(brr)
        If d.exists(brr(j, 1)) Then
          With Sheets("2017")
             .Cells(d(brr(j, 1)), ls + 1) = brr(j, 2)
          End With
        End If
      Next
      End With
    Erase brr
    wb.Close
  MyName = Dir
  
Loop
         

mmwwdd

这个不是太难，给你个思路

cqcbc

我只能做到一个一个文件夹操作，代码如下：
Sub 提取本文件夹多簿指定表区域横向合并到汇总工作簿一张表()
    Dim p$, f$, sh As Worksheet, c&
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sh = ActiveSheet
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xlsx")
    sh.Cells.Clear '清除原数据
    Do While f <> ""
        If InStr(f, ".xlsm") = 0 Then
            With GetObject(p & f)
                Cells(1, 1 + c) = Replace(f, ".xlsx", "")
                .Sheets("蔬菜").UsedRange.Offset(0, 1).Copy sh.Cells(2, c + 1)
                c = c + 2
                .Close False
            End With
        End If
        f = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "汇总完成"
End Sub

3190496160

jjmysjg 发表于 2020-1-27 10:54
把代码中的“水果”改为“蔬菜”，没有汇总进来数据。怎么改才对呢

没有月份标志，肯定汇总不了了文件名称五花八门，根据文件名称根本没法判断月份，

answer6141

我是没有理解，安其他大神的结果，自己做了一个，重在参与，喜欢赏个花
汇总哪年的就全选哪年的文件

varytina

PQ方法供参考，Excel 的月份命名太恶心了，手动改了

dxysong0811

多谢各位大神的解答  问题已解决