求大神帮忙【多个工作簿合并成一个工作簿】

风向标----~

多个项目工作簿，合并成一个工作簿并且是带有计算公式

longwin

Sub test()
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    fname = Dir(ThisWorkbook.Path & "\" & "*店.xlsx")
    Do While fname <> ""
        Set wb0 = Workbooks.Open(ThisWorkbook.Path & "\" & fname)
        wb0.Sheets("自动汇集核算 ").Copy After:=wb.Sheets(wb.Sheets.Count)
        Set sh = wb.Sheets(wb.Sheets.Count)
        sh.Name = Split(wb0.Name, ".")(0)
        wb0.Close
        fname = Dir
    Loop
        MsgBox "ok!"
        Application.ScreenUpdating = True
End Sub

ykcbf1100

附件供参考，多簿合并。

ykcbf1100

多簿合并

1. Sub ykcbf()  '//2024.7.26
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     sh.UsedRange.Clear
   
7.     bt = 4: m = 0
   
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, ThisWorkbook.Name) = 0 Then
    
12.                     fn = fso.GetBaseName(f)
    
13.                     m = m + 1
    
14.                     Set wb = Workbooks.Open(f, 0)
    
15.                     With wb.Sheets(1)
    
16.                         r1 = .Cells(Rows.Count, 1).End(3).Row
    
17.                         .Cells(bt + 1, 3).Resize(r1 - bt) = fn
    
18.                         If m = 1 Then
    
19.                             .Cells.Copy sh.Cells(1, 1)
    
20.                         Else
    
21.                             r = sh.Cells(Rows.Count, 1).End(3).Offset(1).Row
    
22.                             .UsedRange.Offset(bt).Copy sh.Cells(r, 1)
    
23.                         End If
    
24.                     End With
    
25.                     wb.Close 0
    
26.                 End If
    
27.             End If
    
28.         End If
    
29.     Next
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码

风向标----~

ykcbf1100 发表于 2024-7-26 13:37
多簿合并

十分感谢，谢谢

风向标----~

longwin 发表于 2024-7-26 13:34
Sub test()
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook

十分感谢，谢谢