合并同一文件夹下多个工作簿汇总到一个工作表中

529905149

看了论坛许多关于工作簿汇总的贴子， 找了一些感觉适合的代码捣弄了半天，却弄不出想要的结果.
求助各位

hychou33

您好:
關於將不同工作簿的同名工作表進行合併作業，最近剛剛處理到相類似問題，並簡易記錄在博客中，如下所示，供您參考。
https://blog.csdn.net/weixin_42008031/article/details/88769628

thtfzhaobo

也没什么，http://club.excelhome.net/thread-858389-1-13.html

liulang0808

楼主这个是多个工作薄内容拷贝到一个工作薄的一张表内吗？
建议楼主进一步完善附件内容，进行数据模拟
另外http://club.excelhome.net/thread-1258425-1-1.html是遍历文件的资料，楼主可以参考下

529905149

liulang0808 发表于 2019-6-29 08:31
楼主这个是多个工作薄内容拷贝到一个工作薄的一张表内吗？
建议楼主进一步完善附件内容，进行数据模拟
另 ...

这是在论坛上找到，请问如何加上“簿名”“表名”，谢谢。
Sub 合并同一文件夹下多个工作簿汇总到一个工作表中()
Application.ScreenUpdating = False
Dim wb As Excel.Workbook
Dim sh As Excel.Worksheet
Set sh = ThisWorkbook.Worksheets(1)
f = Dir(ThisWorkbook.Path & "\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
  Do While f <> "" '在目录中循环

   If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
     Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f) '依次打开目录工作薄
       n = n + 1
         If n = 1 Then
            arr = wb.Worksheets(1).[b5].CurrentRegion
              Else
          arr = wb.Worksheets(1).[b5].CurrentRegion.Offset(1)
         End If
       Sheet1.Range("a4:z65536") = Clear
'sh.Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)) = arr
      sh.Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)) = arr
        wb.Close False '关闭打开的工作薄
    End If
      f = Dir
    Loop '结束循环
   
    Application.ScreenUpdating = True
    MsgBox "共汇总了" & n & "个文件"
End Sub

lsc900707

附件里并没有代码。合并多簿单表的例子不少，不同的可能就是你要列出簿名和表名而已。
Sub gj23w98()
    Dim brr(1 To 99999, 1 To 14)
    Application.ScreenUpdating = False
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls*")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(p & f)
            Arr = wb.Sheets(1).[b4].CurrentRegion
            For i = 2 To UBound(Arr)
                m = m + 1
                brr(m, 1) = Split(wb.Name, ".xlsx")(0)
                brr(m, 2) = wb.Sheets(1).Name
                For j = 1 To UBound(Arr, 2)
                    brr(m, j + 2) = Arr(i, j)
                Next
            Next
            wb.Close False
        End If
        f = Dir
    Loop
    If m Then
        [a3].CurrentRegion.Offset(1).ClearContents
        [a4].Resize(m, 14) = brr
    End If
    Application.ScreenUpdating = True
    MsgBox "OK!"
End Sub

lsc900707

测试参考附件：

529905149

lsc900707 发表于 2019-6-29 09:02
附件里并没有代码。合并多簿单表的例子不少，不同的可能就是你要列出簿名和表名而已。
Sub gj23w98()
    ...

谢谢，老师。正是想要的结果

jscjch

谢谢，学习！！

yepulu

学习了，我需要。