多源表复制粘贴到同一工作簿指定的工作表

ph378

530.rar (50.96 KB, 下载次数: 9)

2024-5-30 19:49 上传

点击文件名下载附件

quqiyuan

不知道你的需求是否大概这样？
仅供参考

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.30
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     a = [{"01","02","03","04"}]
   
6.     b = [{"进","出","夜班","白班"}]
   
7.     For i = 1 To UBound(a)
   
8.         d(a(i)) = b(i)
   
9.     Next
   
10.     Set ws = ThisWorkbook
    
11.     p = ThisWorkbook.Path & ""
    
12.     On Error Resume Next
    
13.     For Each f In fso.GetFolder(p).Files
    
14.         If LCase$(f.Name) Like "*.xls*" Then
    
15.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
16.                 fn = fso.GetBaseName(f)
    
17.                 Set wb = Workbooks.Open(f, 0)
    
18.                 wb.Sheets(1).Cells.Copy ws.Sheets(d(fn)).[a1]
    
19.                 wb.Close False
    
20.             End If
    
21.         End If
    
22.     Next f
    
23.     Set d = Nothing
    
24.     Application.ScreenUpdating = False
    
25.     MsgBox "OK！"
    
26. End Sub
    

复制代码