多个工作薄合按名称合并到一个工作薄对应的工作表中

春日秋水

求助.zip (17.8 KB, 下载次数: 12)

2024-7-17 20:34 上传

点击文件名下载附件

要求：文件名称包含三班的数据放到合并数据薄中三班的工作表中，包含四班的放到四班的工作表中，
非常感谢

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Dim sht As Worksheet
    Set wb = ThisWorkbook
    p = wb.Path & "\"
    f = Dir(p & "*.xls*")
    Do While f <> ""
        If InStr(f, wb.Name) = 0 Then
            With Workbooks.Open(p & f, 0)
                s = Split(Split(.Name, "-")(1), ".")(0)
                .Sheets(s).UsedRange.Offset(1).Copy wb.Sheets(s).Cells(Rows.Count, 1).End(3).Offset(1)
                .Close 0
            End With
        End If
        f = Dir
    Loop
    Application.ScreenUpdating = True
    Beep
End Sub

ykcbf1100

多工作簿多工作表按表名合并

ykcbf1100

多工作簿按表名合并。

1. Sub ykcbf()   '//2024.7.17  文件合并
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Set sh = ThisWorkbook.Sheets("合并数据")
   
7.     Set ws = ThisWorkbook
   
8.     For Each sht In ws.Sheets
   
9.         If sht.Name <> sh.Name Then
   
10.             sht.Cells.Clear
    
11.             d(sht.Name) = ""
    
12.         End If
    
13.     Next
    
14.     p = ws.Path & ""
    
15.     bt = 1   '//标题行数
    
16.     For Each f In fso.GetFolder(p).Files
    
17.         If f.Name Like "*.xls*" Then
    
18.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
19.                 Set wb = Workbooks.Open(f, 0)
    
20.                 For Each sht In wb.Sheets
    
21.                     If d.exists(sht.Name) Then
    
22.                         If sht.UsedRange.Count > 1 Then
    
23.                             With sht
    
24.                                 fn = .Name
    
25.                                 If ws.Sheets(fn).UsedRange.Count > 1 Then
    
26.                                     r = ws.Sheets(fn).Cells(Rows.Count, 1).End(3).Offset(1).Row
    
27.                                     sht.UsedRange.Offset(bt).Copy ws.Sheets(fn).Cells(r, 1)
    
28.                                 Else
    
29.                                     sht.UsedRange.Copy ws.Sheets(fn).[a1]
    
30.                                 End If
    
31.                             End With
    
32.                         End If
    
33.                     End If
    
34.                 Next
    
35.                 wb.Close False
    
36.             End If
    
37.         End If
    
38.     Next f
    
39.     Set d = Nothing
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    

复制代码

limonet

SQL不一定能运行，用数组或JS吧。

春日秋水

ykcbf1100 发表于 2024-7-17 21:08
多工作簿按表名合并。

达到要求，非常感谢

jjmysjg

quqiyuan 发表于 2024-7-17 20:58
参与一下，供参考。。。

增加一个工作簿，为何合并不了？

quqiyuan

jjmysjg 发表于 2024-7-21 16:49
增加一个工作簿，为何合并不了？

你增加的工作簿名称是否跟前面一样，都是：

这个样式，名称在汇总表里也要有哦