合并表格到工作簿问题求助。

yyyeng · 发表于 2023-7-20 09:56

多个excel文件中有几个文件名开头几个字是相同的，需要将文件名开头相同的表格合并到一个工作簿中的sheet1、sheet2、sheet3、……，合并后的工作簿文件名取此开头相同的部分即可，请大师帮助解决！

半百 · 发表于 2023-7-20 10:14

我觉得你应该手工列出前边相同字符的名单，比如，第一中学、第二中学、第三中学、第十五中学，等等，然后根据这个名单去合并。

3190496160 · 发表于 2023-7-20 11:04

如果给你代码，你能根据自己的实际表格情况修改调整代码的话，目前的附件就行，如果你自己不能修改调整代码的话，最好是上传真实的文件表格，最起码表格结构要跟实际的一致

ykcbf1100 · 发表于 2023-7-20 11:17

附件供参考。。。

3190496160 · 发表于 2023-7-20 11:21

Sub 合并()
Application.ScreenUpdating = False
Dim d As Object
Dim rr()
ReDim rr(1 To 5000)
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\合并学校工作簿\"
f = Dir(lj & "*.xls*")
Do While f <> ""
n = n + 1
rr(n) = lj & f
zd = Left(f, 4)
d(zd) = ""
f = Dir
Loop
For Each k In d.keys
m = 0
For i = 1 To n
      If InStr(rr(i), k) > 0 Then
         m = m + 1
         Set wb = Workbooks.Open(rr(i))
         mc = Replace(Split(wb.Name, ".")(0), k, "")
         If m = 1 Then
            wb.Worksheets(1).Copy
            Set ww = ActiveWorkbook
            ww.Worksheets(1).Name = mc
         Else
            wb.Worksheets(1).Copy after:=ww.Worksheets(ww.Worksheets.Count)
            ww.Worksheets(ww.Worksheets.Count).Name = mc
         End If
         wb.Close False
      End If
Next i
ww.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
ww.Close
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2023-7-20 11:22

3190496160 · 发表于 2023-7-20 11:23

新建文件夹.rar (72.11 KB, 下载次数: 10)

Lovertdos · 发表于 2023-7-20 11:28

3190496160 发表于 2023-7-20 11:23

你猜楼主会不会来个第十一中学、第十二中学

cyq4896 · 发表于 2023-7-20 11:59

参与一下...

3190496160 · 发表于 2023-7-20 12:17

Lovertdos 发表于 2023-7-20 11:28
你猜楼主会不会来个第十一中学、第十二中学

没这份闲心去猜

		自动登录	找回密码
密码			免费注册

[求助] 合并表格到工作簿问题求助。