A、B、C这三个工作簿的数据都在sheet1,表头一样
Sub MergeWorkbooks()
Dim FolderPath As String
Dim FileName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim mainWb As Workbook
Dim mainWs As Worksheet
Dim lastRow As Long
Dim lastcol As Long
Dim pasteRange As Range
' 主工作簿设置为当前工作簿
Set mainWb = ThisWorkbook
Set mainWs = mainWb.Sheets(1) ' 假设数据合并到第一张表中
mainWs.Cells.Clear
' 获取文件夹路径(你可以根据需求修改文件夹路径)
'FolderPath = "D:\VBA\hebin\" ' 更改为你实际存储文件的路径
FolderPath = ThisWorkbook.Path & "\"
' 确保路径以反斜杠结尾
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath & "\"
End If
' 获取第一个Excel文件
FileName = Dir(FolderPath & "*.xlsx")
' 如果找不到任何文件,则提示并退出
If FileName = "" Then
MsgBox "未找到任何Excel文件,请检查路径或文件格式。"
Exit Sub
End If
' 循环所有Excel文件
Do While FileName <> mainWb.Name
' 打开工作簿
On Error Resume Next
Set wb = Workbooks.Open(FolderPath & FileName)
If Err.Number <> 0 Then
MsgBox "无法打开文件:" & FileName
Err.Clear
Exit Sub
End If
On Error GoTo 0
' 假设数据在每个工作簿的第一张表中,找到最后一行并复制数据
Set ws = wb.Sheets(1)
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastcol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
ws.Cells(1, 1).Resize(1, lastcol).Copy Destination:=mainWs.Cells(1, 1)
' 查找主工作簿中当前的最后一行
If Application.WorksheetFunction.CountA(mainWs.Cells) > 0 Then
Set pasteRange = mainWs.Cells(mainWs.Rows.Count, 1).End(xlUp).Offset(1, 0)
Else
Set pasteRange = mainWs.Cells(1, 1)
End If
' 复制工作簿中的数据并粘贴到主工作簿
'ws.Range("A1:" & ws.Cells(lastcol, lastRow).Address).Copy
ws.Range("A2:E" & lastRow).Copy
mainWs.Paste Destination:=pasteRange
' 关闭工作簿(不保存)
wb.Close False
' 获取下一个文件
FileName = Dir
Loop
With mainWs.Cells
.HorizontalAlignment = xlCenter '设置水平居中
.VerticalAlignment = xlCenter '设置垂直居中
.Font.Size = 14
End With
' 完成后提示
MsgBox "所有工作簿已成功合并!"
End Sub
循环获取文件夹中的每个文件
Sub ListFiles()
Dim fileName As String
' 第一次调用 Dir 并传入路径,获取第一个文件
fileName = Dir(ThisWorkbook.Path & "/")
' 使用循环,逐步获取下一个文件
Do While fileName <> ""
MsgBox fileName ' 显示文件名
fileName = Dir ' 不带参数,获取下一个文件
Loop
End Sub
’如果想要获取路径,就Thisworkbook.Path & "/" & filename