用Excel VBA如何合并同一文件夹下的所有工作簿的第一张工作表?

您好！

答案如下，请参考。

比如，下图为公司各部门员工的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

希望以上的方法可以帮助到你。谢谢！

可以在Excel表格中用下面的VBA程序实现：
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

怎样合并，请举例说明