|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub 合并多工作簿()
- Dim MyPath$, MyFile$, Wb As Workbook, x&, k&, y1&, y&
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- MyPath = ThisWorkbook.Path & "\分表"
- MyFile = Dir(MyPath & "\*.*")
- ThisWorkbook.Sheets("多工作簿合并").Cells = ""
- Do
- Workbooks.Open Filename:=MyPath & "" & MyFile
- Set Wb = ActiveWorkbook
- With Wb
- For x = 1 To .Sheets.Count
- k = k + 1
- If k = 1 Then
- .Sheets(x).Range("A1").CurrentRegion.Copy
- ThisWorkbook.Sheets("多工作簿合并").Range("a1").PasteSpecial xlPasteAll
- y1 = ThisWorkbook.Sheets("多工作簿合并").Cells(Rows.Count, 2).End(xlUp).Row
- Else
- y = ThisWorkbook.Sheets("多工作簿合并").Cells(Rows.Count, 2).End(xlUp).Row
- .Sheets(x).Range("A1").CurrentRegion.Offset(3, 0).Copy
- ThisWorkbook.Sheets("多工作簿合并").Range("a" & y + 1).PasteSpecial xlPasteAll
- y1 = ThisWorkbook.Sheets("多工作簿合并").Cells(Rows.Count, 2).End(xlUp).Row
- End If
- Next x
- .Close
- End With
- MyFile = Dir
- Loop While MyFile <> ""
- ThisWorkbook.Sheets("多工作簿合并").Cells.EntireColumn.AutoFit
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|