用Excel VBA如何合并同一文件夹下的所有工作簿的第一张工作表? 50
您好！
答案如下，请参考。
比如，下图为公司各部门员工的KPI信息，我们要把它们汇总到同一工作簿中。
解决方案的最终效果，如下演示：
此方案主要功能：
⓵单击“合并所有工作簿”命令按钮，系统自动实现合并功能；
⓶执行命令后，系统自动弹出一“提示”对话框，显示合并的工作簿信息；
⓷当部门员工的信息有更改时，再次单击按钮，汇总数据随时刷新。
实现以上功能的代码如下：
Sub CombineWbs()
Dim bt As Range, r As Long, c As Long
r = 1
c = 7
Dim wt As Worksheet
Set wt = ThisWorkbook.Worksheets(1)
wt.Rows(r + 1 & ":1048576").ClearContents
Application.ScreenUpdating = False
Dim FileName As String, sht As Worksheet, wb As Workbook, WbN As String
Dim Erow As Long, fn As String, arr As Variant, Num As Long
FileName = Dir(ThisWorkbook.Path & "*.xlsx")
Num = 0
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then
Erow = wt.Range("A1").CurrentRegion.Rows.Count + 1
fn = ThisWorkbook.Path & "" & FileName
Set wb = GetObject(fn)
Set sht = wb.Worksheets(1)
Num = Num + 1
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1048576, "B").End(xlUp).Offset(0, 7))
wt.Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
WbN = WbN & Chr(13) & wb.Name
wb.Close False
End If
FileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub
希望以上的方法可以帮助到你。谢谢！
Sub Test() '打开当前目录下文件，将Sheet1信息复制到汇总表上
Dim f$
Dim n&
Mypath = ThisWorkbook.Path & "\"
f = Dir(Mypath & "*.xls*")
Do While f > " "
n = n + 1
Workbooks.Open Mypath & f
Set c = ActiveWorkbook
arr=sheet1.UsedRange
c.Close
Cells(n, 1).resze(Ubound(arr,1),Ubound(arr,2)) =arr
n=n+Ubound(arr,1)
f = Dir
Loop
End Sub
