急！如何将同一文件夹下的不同工作簿相同名称的工作表合并在一起

INaga2018

lsc900707 发表于 2024-7-10 19:52
厉害呀，附件都不需要准备！

版主别挖苦我了，几年前自学了一段时间的VBA，会了一点皮毛，现在重新捡起来发现自己写的狗屎一样，所以过来请教学习。这个问题其实是一类的需求，附件确实是应该给，这样才能针对性解决问题，后面紧记。

ykcbf1100

INaga2018 发表于 2024-7-11 11:34
版主别挖苦我了，几年前自学了一段时间的VBA，会了一点皮毛，现在重新捡起来发现自己写的狗屎一样，所以 ...

求助的关键是上传附件，如果有附件，问题早解决了。

INaga2018

ykcbf1100 发表于 2024-7-11 12:36
求助的关键是上传附件，如果有附件，问题早解决了。

老师好，已补发附件，帮看下

INaga2018

yes_cn 发表于 2024-7-10 15:13
没有你上传的文件夹内容，无法帮你调试，只有你自己去搞定了。

大佬已补发附件，原有代码已调试，但是自己不能解决合并指定工作表的内容，帮调整下，谢谢。

lsc900707

INaga2018 发表于 2024-7-11 11:34
版主别挖苦我了，几年前自学了一段时间的VBA，会了一点皮毛，现在重新捡起来发现自己写的狗屎一样，所以 ...

不是挖苦，确实是提问的关键。

ykcbf1100

INaga2018 发表于 2024-7-11 14:45
老师好，已补发附件，帮看下

多工作簿多工作表合并，取消筛选，取消隐藏行

ykcbf1100

多工作簿多工作表合并

1. Sub ykcbf()   '//2024.7.11
   
2.     Dim wb, ws
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Dim tm: tm = Timer
   
8.     Set ws = ThisWorkbook
   
9.     p = ThisWorkbook.Path & ""
   
10.     On Error Resume Next
    
11.     For Each sht In ws.Sheets
    
12.         If InStr(sht.Name, "操作") = 0 Then
    
13.             sht.Delete
    
14.         End If
    
15.     Next
    
16.     For Each f In fso.GetFolder(p).Files
    
17.         If InStr(f, ws.Name) = 0 Then
    
18.             Set wb = Workbooks.Open(f, 0)
    
19.             For Each sht In wb.Sheets
    
20.                 d(sht.Name) = ""
    
21.             Next
    
22.             wb.Close 0
    
23.         End If
    
24.     Next f
    
25.     For Each k In d.keys
    
26.         m = 0
    
27.         ReDim brr(1 To 10000, 1 To 100)
    
28.         For Each f In fso.GetFolder(p).Files
    
29.             If InStr(f, ws.Name) = 0 Then
    
30.                 Set wb = Workbooks.Open(f, 0)
    
31.                 For Each sht In wb.Sheets
    
32.                     If InStr(sht.Name, k) Then
    
33.                         m = m + 1
    
34.                         With sht
    
35.                             .UsedRange.EntireRow.Hidden = False    '//取消隐藏行
    
36.                             .AutoFilterMode = False                '//取消筛选状态
    
37.                             If m = 1 Then
    
38.                                 Set sht1 = ws.Sheets.Add(After:=ws.Sheets(ws.Sheets.Count))
    
39.                                 sht1.Name = .Name
    
40.                                 .Cells.Copy sht1.[a1]
    
41.                             Else
    
42.                                 r1 = ws.Sheets(sht.Name).Cells(Rows.Count, 1).End(3).Row
    
43.                                 .UsedRange.Offset(1).Copy ws.Sheets(sht.Name).Cells(r1 + 1, 1)
    
44.                             End If
    
45.                         End With
    
46.                     End If
    
47.                 Next
    
48.                 wb.Close 0
    
49.             End If
    
50.         Next f
    
51.     Next
    
52.     ws.Sheets("操作表").Activate
    
53.     Set d = Nothing
    
54.     Application.ScreenUpdating = True
    
55.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
56. End Sub
    
57. 
    

复制代码

yes_cn

将待合并的源文件都放在名为HB的文件夹中，路径是D:\HB，准备接收数据的文件名为HB.xlsm，存放于D:\

jjmysjg

lsc900707 发表于 2024-7-11 15:35
不是挖苦，确实是提问的关键。

按工作表名合并

lsc900707

jjmysjg 发表于 2024-7-11 16:24
没有按工作表名合并

补充：附件有3个工作薄，每个工作薄有多个工作表，并且都有一个表名为xx01的工作表。只将表名为xx01的工作表内容合并在一起，其他表内容不合并。

我理解错了？