多个工作簿合并问题

msw2395

多个不同工作簿合并成1个工作簿，如何设置，求帮忙解答，谢谢!!

痛痛痛痛

慧办公插件，免费版有个数限制。要么vba

ykcbf1100

和上题差不多的，除了路径改一下，其它都不用改的。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.7.20  多工作簿合并
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     sh.UsedRange.Clear
   
6.     p = ThisWorkbook.Path & "\dj\280"
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If LCase$(f.Name) Like "*.xls*" Then
   
9.             m = m + 1
   
10.             Set wb = Workbooks.Open(f, 0)
    
11.             With wb.Sheets(1)
    
12.                 r = .Cells(Rows.Count, 1).End(3).Row
    
13.                 c = .UsedRange.Columns.Count
    
14.                 arr = .[a1].Resize(r, c)
    
15.             End With
    
16.             wb.Close False
    
17.             If m = 1 Then
    
18.                 sh.Cells(1, 1).Resize(r, c) = arr
    
19.             Else
    
20.                 col = sh.Cells(1, 255).End(1).Column + 2
    
21.                 sh.Cells(1, col).Resize(r, c) = arr
    
22.             End If
    
23.         End If
    
24.     Next f
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    

复制代码

quqiyuan

vba参与一下，供参考。。。

quqiyuan

代码如下。。。
Sub test1()
    Application.ScreenUpdating = False
    Dim c&, p$, f$, wb As Workbook
    Dim ws As Worksheet, sht As Worksheet
    Set wb = ThisWorkbook
    p = wb.Path & "\dj\280\"
    Set sht = wb.Sheets("汇总")
    sht.UsedRange.Clear
    f = Dir(p & "*.xls*")
    Do While f <> ""
        With Workbooks.Open(p & f, 0)
            For Each ws In .Worksheets
                c = sht.Cells(1, Columns.Count).End(1).Column
                With ws
                    If c = 1 Then
                        ws.UsedRange.Copy sht.[a1]
                    Else
                        ws.UsedRange.Copy sht.Cells(1, c + 2)
                    End If
                End With
            Next
            .Close 0
        End With
        f = Dir
    Loop
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Beep
End Sub

msw2395

非常感谢ykcbf1100、quqiyuan2位老师的解答！没鲜花评不了分，谁知道如何获得，能充值购买吗

zpy2

msw2395 发表于 2024-7-21 09:39
非常感谢ykcbf1100、quqiyuan2位老师的解答！没鲜花评不了分，谁知道如何获得，能充值购买吗

已评。鲜花，经常性来论坛逛逛就行了

msw2395

zpy2 发表于 2024-7-21 12:14
已评。鲜花，经常性来论坛逛逛就行了

好的，谢谢！