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

limonet

zpy2 发表于 2024-7-12 12:17
那这些 array里面的参数哪里可以查到啊？

您是指怎么先得到“xx01”吗？

opiona

https://club.excelhome.net/thread-1409141-1-1.html

zpy2

limonet 发表于 2024-7-12 13:07
您是指怎么先得到“xx01”吗？

TABLE_CATALOG
TABLE_SCHEMA
TABLE_NAME
TABLE_TYPE

是这些参数吗？

limonet

zpy2 发表于 2024-7-12 18:10
TABLE_CATALOG
TABLE_SCHEMA
TABLE_NAME

是的，就这些。

jjmysjg

yes_cn 发表于 2024-7-11 15:56
将待合并的源文件都放在名为HB的文件夹中，路径是D:\HB，准备接收数据的文件名为HB.xlsm，存放于D:\

对于数据源文件夹，能选择文件夹吗

yes_cn

jjmysjg 发表于 2024-7-21 17:50
对于数据源文件夹，能选择文件夹吗

当初是为了快速解决合并的问题，现在做了些优化。

• 移除了对特定文件名（HB.xlsm）的引用。现在代码假设当前打开的工作簿就是目标工作簿。
• 使用 ThisWorkbook.Path 来获取当前工作簿所在的文件夹路径，这样就不需要硬编码文件路径了。
  

1. Sub AutoMergeWorksheets()
   
2.     Dim sourceFolder As String
   
3.     Dim fileName As String
   
4.     Dim wb As Workbook
   
5.     Dim ws As Worksheet
   
6.     Dim targetWb As Workbook
   
7.     Dim targetWs As Worksheet
   
8.     Dim lastRow As Long
   
9.     Dim processedSheets As Collection
   
10.     Dim sheetName As String
    
11.     Dim initialSheetCount As Integer
    
12.     Dim addedSheets As Integer
    
13.    
    
14.     ' 设置源文件夹为当前工作簿所在的文件夹
    
15.     sourceFolder = ThisWorkbook.Path & ""
    
16.    
    
17.     ' 设置目标工作簿为当前工作簿
    
18.     Set targetWb = ThisWorkbook
    
19.    
    
20.     ' 记录初始工作表数量
    
21.     initialSheetCount = targetWb.Sheets.Count
    
22.    
    
23.     ' 创建一个集合来存储已处理的工作表名称
    
24.     Set processedSheets = New Collection
    
25.    
    
26.     addedSheets = 0
    
27.    
    
28.     ' 遍历源文件夹中的所有Excel文件
    
29.     fileName = Dir(sourceFolder & "*.xls*")
    
30.    
    
31.     Do While fileName <> ""
    
32.         ' 跳过目标文件自身
    
33.         If LCase(fileName) <> LCase(ThisWorkbook.Name) Then
    
34.             ' 打开源工作簿
    
35.             Set wb = Workbooks.Open(sourceFolder & fileName, ReadOnly:=True)
    
36.             
    
37.             ' 遍历工作簿中的所有工作表
    
38.             For Each ws In wb.Worksheets
    
39.                 sheetName = ws.Name
    
40.                
    
41.                 ' 检查工作表是否有内容
    
42.                 If Application.WorksheetFunction.CountA(ws.UsedRange) > 0 Then
    
43.                     ' 检查是否存在同名工作表
    
44.                     Set targetWs = Nothing
    
45.                     On Error Resume Next
    
46.                     Set targetWs = targetWb.Sheets(sheetName)
    
47.                     On Error GoTo 0
    
48.                     
    
49.                     If targetWs Is Nothing Then
    
50.                         ' 如果不存在同名工作表，直接复制
    
51.                         ws.Copy After:=targetWb.Sheets(targetWb.Sheets.Count)
    
52.                         Set targetWs = targetWb.Sheets(targetWb.Sheets.Count)
    
53.                         addedSheets = addedSheets + 1
    
54.                         Debug.Print "新增工作表: " & sheetName
    
55.                     Else
    
56.                         ' 如果存在同名工作表，合并数据
    
57.                         lastRow = targetWs.Cells(targetWs.Rows.Count, 1).End(xlUp).Row
    
58.                         
    
59.                         ' 复制数据（包括隐藏的行和筛选）
    
60.                         If lastRow > 1 Then ' 如果目标工作表不为空
    
61.                             ws.UsedRange.Offset(1).Resize(ws.UsedRange.Rows.Count - 1).Copy
    
62.                             targetWs.Cells(lastRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    
63.                         Else ' 如果目标工作表为空
    
64.                             ws.UsedRange.Copy
    
65.                             targetWs.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    
66.                         End If
    
67.                         
    
68.                         Debug.Print "合并工作表: " & sheetName
    
69.                     End If
    
70.                     
    
71.                     ' 确保自动筛选已应用
    
72.                     If Not targetWs.AutoFilterMode Then
    
73.                         targetWs.UsedRange.AutoFilter
    
74.                     End If
    
75.                     
    
76.                     ' 将处理过的工作表名称添加到集合中
    
77.                     On Error Resume Next
    
78.                     processedSheets.Add sheetName, sheetName
    
79.                     On Error GoTo 0
    
80.                 End If
    
81.             Next ws
    
82.             
    
83.             ' 关闭源工作簿
    
84.             wb.Close SaveChanges:=False
    
85.         End If
    
86.         
    
87.         ' 获取下一个文件名
    
88.         fileName = Dir()
    
89.     Loop
    
90.    
    
91.     ' 对工作表进行升序排列
    
92.     Call SortSheetsAlphabetically(targetWb)
    
93.    
    
94.     ' 保存目标工作簿
    
95.     targetWb.Save
    
96.    
    
97.     MsgBox "合并完成！结果已保存在当前工作簿中。" & vbNewLine & _
    
98.            "初始工作表数量: " & initialSheetCount & vbNewLine & _
    
99.            "新增工作表数量: " & addedSheets & vbNewLine & _
    
100.            "最终工作表数量: " & targetWb.Sheets.Count & vbNewLine & _
     
101.            "处理的工作表数量: " & processedSheets.Count
     
102. End Sub
     
103. 
     
104. Sub SortSheetsAlphabetically(wb As Workbook)
     
105.     Dim i As Integer
     
106.     Dim j As Integer
     
107.    
     
108.     For i = 1 To wb.Sheets.Count
     
109.         For j = i + 1 To wb.Sheets.Count
     
110.             If UCase(wb.Sheets(j).Name) < UCase(wb.Sheets(i).Name) Then
     
111.                 wb.Sheets(j).Move Before:=wb.Sheets(i)
     
112.             End If
     
113.         Next j
     
114.     Next i
     
115. End Sub

复制代码