多工作簿合并

ykcbf1100

按1楼题意重写一个。。。

1. Sub ykcbf()  '//2024.12.7
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Dim tm: tm = Timer
   
6.     Set ws = ThisWorkbook
   
7.     Set sh = ws.Sheets("操作台")
   
8.     For Each sht In Sheets
   
9.         If sht.Name <> sh.Name Then sht.Delete
   
10.     Next
    
11.     p = ThisWorkbook.Path & ""
    
12.     For Each f In fso.GetFolder(p).Files
    
13.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
14.             fn = fso.GetBaseName(f)
    
15.             fn = Left(fn, 1) & "（" & ston(fn) & "）班"
    
16.             Set wb = Workbooks.Open(f, 0)
    
17.             wb.Sheets(1).Copy After:=ws.Sheets(ws.Sheets.Count)
    
18.             Set sht = ws.Sheets(ws.Sheets.Count)
    
19.             sht.Name = fn
    
20.             wb.Close 0
    
21.         End If
    
22.     Next f
    
23.     sh.Activate
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
26. End Sub
    
27. 
    
28. Function ston(str) As String
    
29.     Dim reg As Object
    
30.     Set reg = CreateObject("VBScript.RegExp")
    
31.     With reg
    
32.         .Pattern = "[^\d]+"
    
33.         .Global = True
    
34.         .IgnoreCase = True
    
35.     End With
    
36.     ston = reg.Replace(str, "")
    
37.     Set reg = Nothing
    
38. End Function
    

复制代码

trd1898

可以可以，各位老师写得代码，我都能用上。谢谢

chxw68

feilanga 发表于 2024-12-6 16:38
么有节操了。很明显chxw68老师的解答才符合你的需求

谢谢！萝卜白菜各有所爱。