急！如何将同一文件夹下的不同工作簿相同名称的工作表合并在一起

INaga2018 · 发表于 2024-7-10 14:56

本帖最后由 INaga2018 于 2024-7-11 14:45 编辑

如题，需要将同一文件夹下的不同工作簿相同名称的工作表合并在一起，每个表的表头字段是相同的，但是有些工作表有筛选和隐藏，需要全部复制过来合并在一张新的工作表中，在线急等，谢谢各位！
补充：附件有3个工作薄，每个工作薄有多个工作表，并且都有一个表名为xx01的工作表。只将表名为xx01的工作表内容合并在一起，其他表内容不合并。

yes_cn · 发表于 2024-7-10 15:13

没有你上传的文件夹内容，无法帮你调试，只有你自己去搞定了。

folderPath：指定包含Excel文件的文件夹路径。fileName：获取文件夹中所有Excel文件的名称。Application.ScreenUpdating 和 Application.DisplayAlerts：禁用屏幕更新和警告，以提高宏的运行速度。wsMaster：在当前工作簿中创建或获取合并后的工作表。循环遍历文件和工作表：遍历每个文件和每个工作表，将数据合并到wsMaster中。

Sub CombineSheets()
Dim folderPath As String
Dim fileName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim wsMaster As Worksheet
Dim sheetName As String
Dim lastRow As Long
Dim lastMasterRow As Long
Dim firstHeader As Boolean
folderPath = "C:\path_to_your_folder" ' 修改为你的文件夹路径
fileName = Dir(folderPath & "*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wsMaster = ThisWorkbook.Sheets(1) ' 合并后的数据将被放置在此工作簿的第一个工作表中
Do While fileName <> ""
Set wb = Workbooks.Open(folderPath & fileName)
For Each ws In wb.Sheets
sheetName = ws.Name
On Error Resume Next
Set wsMaster = ThisWorkbook.Sheets(sheetName)
On Error GoTo 0
If wsMaster Is Nothing Then
Set wsMaster = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsMaster.Name = sheetName
firstHeader = True
Else
firstHeader = False
End If
' 取消筛选
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
' 显示所有隐藏的行和列
ws.Cells.EntireRow.Hidden = False
ws.Cells.EntireColumn.Hidden = False
lastMasterRow = wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp).Row
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If firstHeader Then
ws.Rows("1:" & lastRow).Copy wsMaster.Rows(lastMasterRow + 1)
Else
ws.Rows("2:" & lastRow).Copy wsMaster.Rows(lastMasterRow + 1)
End If
Next ws
wb.Close False
fileName = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

复制代码

ykcbf1100 · 发表于 2024-7-10 16:01

楼主还是上传一个附件吧，这个问题其实不难。

3190496160 · 发表于 2024-7-10 16:11

就是一个合并多薄多表为一薄多表的问题，
可以看看这个帖子
合并工具-Excel VBA程序开发-ExcelHome技术论坛 - https://club.excelhome.net/thread-1639995-1-1.html

kyxfyzg · 发表于 2024-7-10 16:20

Sub test()
Application.DisplayAlerts = False
Dim sh As Worksheet
lj = ThisWorkbook.Path & "\"
wjm = Dir(lj & "*.xlsx")
Do While wjm <> ""
      If wjm <> ThisWorkbook.Name Then
         Workbooks.Open lj & wjm
         For Each sh In Worksheets
            For i = 1 To ThisWorkbook.Sheets.Count
                  If sh.Name = ThisWorkbook.Sheets(i).Name Then
                     sh.UsedRange.AutoFilter
                     sh.UsedRange.EntireRow.Hidden = False
                     h = ThisWorkbook.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
                     sh.UsedRange.Copy ThisWorkbook.Sheets(i).Cells(h + 1, 1)
                  End If
            Next i
         Next sh
         ActiveWorkbook.Close
      End If
      wjm = Dir
Loop
Application.DisplayAlerts = True
End Sub

jjmysjg · 发表于 2024-7-10 17:29

yes_cn 发表于 2024-7-10 15:13
没有你上传的文件夹内容，无法帮你调试，只有你自己去搞定了。

所有表合并到一个表中，没有按表名分别合并

yes_cn · 发表于 2024-7-10 18:58

jjmysjg 发表于 2024-7-10 17:29
所有表合并到一个表中，没有按表名分别合并

Sub MergeWorksheets()
Dim folderPath As String
Dim fileName As String
Dim workbook As Workbook
Dim worksheet As Worksheet
Dim masterWorkbook As Workbook
Dim masterWorksheet As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim i As Long
Dim targetSheetName As String
Dim cell As Range
' 设置文件夹路径
folderPath = InputBox("请输入包含Excel文件的文件夹路径:")
If folderPath = "" Then Exit Sub
' 设置目标工作表名称
targetSheetName = InputBox("请输入要合并的工作表名称:")
If targetSheetName = "" Then Exit Sub
' 创建新的主工作簿
Set masterWorkbook = Workbooks.Add
Set masterWorksheet = masterWorkbook.Sheets(1)
masterWorksheet.Name = targetSheetName
' 遍历文件夹中的所有Excel文件
fileName = Dir(folderPath & "\*.xls*")
Do While fileName <> ""
' 打开工作簿
Set workbook = Workbooks.Open(folderPath & "" & fileName)
' 检查是否存在目标工作表
On Error Resume Next
Set worksheet = workbook.Sheets(targetSheetName)
On Error GoTo 0
If Not worksheet Is Nothing Then
' 如果主工作表为空，复制表头
If masterWorksheet.UsedRange.Rows.Count = 1 And IsEmpty(masterWorksheet.Cells(1, 1)) Then
worksheet.Rows(1).Copy Destination:=masterWorksheet.Rows(1)
End If
' 获取数据范围
lastRow = worksheet.Cells(worksheet.Rows.Count, 1).End(xlUp).Row
lastCol = worksheet.Cells(1, worksheet.Columns.Count).End(xlToLeft).Column
' 复制数据（包括隐藏的行）
worksheet.Range(worksheet.Cells(2, 1), worksheet.Cells(lastRow, lastCol)).Copy
' 粘贴到主工作表
lastRow = masterWorksheet.Cells(masterWorksheet.Rows.Count, 1).End(xlUp).Row
masterWorksheet.Cells(lastRow + 1, 1).PasteSpecial xlPasteValues
masterWorksheet.Cells(lastRow + 1, 1).PasteSpecial xlPasteFormats
' 复制列宽
For i = 1 To lastCol
masterWorksheet.Columns(i).ColumnWidth = worksheet.Columns(i).ColumnWidth
Next i
End If
' 关闭工作簿
workbook.Close SaveChanges:=False
' 获取下一个文件名
fileName = Dir()
Loop
' 应用自动筛选
masterWorksheet.UsedRange.AutoFilter
' 保存并关闭主工作簿
masterWorkbook.SaveAs folderPath & "\合并结果_" & targetSheetName & ".xlsx"
masterWorkbook.Close SaveChanges:=True
MsgBox "合并完成！结果保存在：" & folderPath & "\合并结果_" & targetSheetName & ".xlsx"
End Sub

复制代码

lsc900707 · 发表于 2024-7-10 19:52

厉害呀，附件都不需要准备！

ykcbf1100 · 发表于 2024-7-11 07:39

yes_cn 发表于 2024-7-10 18:58

AI写的代码并不一定实用，参考一下是可以的。

mmwwdd · 发表于 2024-7-11 08:19

这种问题一搜一大把

		自动登录	找回密码
密码			免费注册

[求助] 急！如何将同一文件夹下的不同工作簿相同名称的工作表合并在一起

评分

评分

评分

评分

评分

评分