vba 快速合并当前文件夹内多个excel的指定工作表到一个同名工作表并打开,避免内容为空及提示下标越界
时间: 2024-01-29 15:03:23 浏览: 110
很抱歉,我之前的回答有误,以下是正确的 VBA 代码:
```VBA
Sub MergeWorksheets()
Dim folderPath As String
Dim targetWorksheetName As String
Dim targetWorkbook As Workbook
Dim targetWorksheet As Worksheet
Dim sourceWorkbook As Workbook
Dim sourceWorksheet As Worksheet
Dim targetRow As Long
'获取当前文件夹路径
folderPath = ThisWorkbook.Path
'获取目标工作表名称
targetWorksheetName = ActiveSheet.Name
'创建目标工作簿
Set targetWorkbook = Workbooks.Add
'创建目标工作表
Set targetWorksheet = targetWorkbook.Sheets.Add(After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count))
targetWorksheet.Name = targetWorksheetName
'循环遍历当前文件夹内所有Excel文件
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
'打开Excel文件
Set sourceWorkbook = Workbooks.Open(folderPath & filename)
'循环遍历所有工作表
For Each sourceWorksheet In sourceWorkbook.Worksheets
'判断工作表名称是否与目标工作表名称相同
If sourceWorksheet.Name = targetWorksheetName Then
'将非空内容复制到目标工作表
sourceWorksheet.UsedRange.Copy
targetRow = targetWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
targetWorksheet.Cells(targetRow + 1, "A").PasteSpecial xlPasteAll
End If
Next sourceWorksheet
'关闭Excel文件
sourceWorkbook.Close False
'获取下一个Excel文件名
filename = Dir()
Loop
'清除剪贴板内容
Application.CutCopyMode = False
'选中目标工作表第一个单元格
targetWorksheet.Cells(1, 1).Select
'保存并打开目标工作簿
targetWorkbook.SaveAs folderPath & targetWorksheetName & ".xlsx"
targetWorkbook.Close True
End Sub
```
将以上代码复制到一个新的 VBA 模块中,然后在需要执行合并操作的 Excel 文件中按下 Alt + F8 快捷键,选择 `MergeWorksheets` 宏,点击运行即可。请注意备份文件,以防数据丢失。
阅读全文