用VBA将多个工作簿中本月的数据合并到一张工作表中

peoples100

求助：怎样用VBA将多个工作簿中的数据合并到一张工作表中，合并后的表格我只要本月的数据。工作中经常用到，我学了很久还是不会，请教了

peoples100

刚才没有上传文件

ykcbf1100

多表合并

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.28    多表合并
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set ws = ThisWorkbook
   
6.     yf = Month(Date)
   
7.     On Error Resume Next
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If LCase(f.Name) Like "*.xls*" Then
   
10.             If InStr(f, "~$") = 0 Then
    
11.                 If InStr(f, ws.Name) = 0 Then
    
12.                     fn = fso.GetBaseName(f)
    
13.                     Set wb = Workbooks.Open(f, 0)
    
14.                     m = 0
    
15.                     With wb.Sheets(1)
    
16.                         r = .Cells(Rows.Count, 1).End(3).Row
    
17.                         c = .Cells(1, "XFD").End(1).Column
    
18.                         arr = .[a1].Resize(r, c)
    
19.                     End With
    
20.                     wb.Close 0
    
21.                     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
22.                     For i = 2 To UBound(arr)
    
23.                         If Month(CDate(arr(i, 1))) = yf Then
    
24.                             m = m + 1
    
25.                             For j = 1 To UBound(arr, 2)
    
26.                                 brr(m, j) = arr(i, j)
    
27.                             Next
    
28.                         End If
    
29.                     Next
    
30.                     With ws.Sheets(fn)
    
31.                         .UsedRange.Offset(1).ClearContents
    
32.                         .Columns(2).NumberFormatLocal = "@"
    
33.                         .[a2].Resize(m, c) = brr
    
34.                         .[a2].Resize(m, c).Borders.LineStyle = 1
    
35.                     End With
    
36.                 End If
    
37.             End If
    
38.         End If
    
39.     Next
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    
43. 
    

复制代码

peoples100

ykcbf1100 发表于 2024-8-28 07:43
参与一下。。。

感谢！！！！！学到了