工作簿合并（合成单表）

wslpsjh

VBA小白求助，工作簿合并（合成单表），只保留一个表头，从第八行开始提取，删除空白行。谢谢！！！

cnmlgb9998

PQ解千愁！！！！！！！！！！！！！！！！！！！！！！！

wfywc81

用ChatGPT花了1分钟写的，请查收！

fzxba

测试.zip (379.4 KB, 下载次数: 9)

2024-3-12 07:09 上传

点击文件名下载附件

ykcbf1100

参与一下，copy法。

ykcbf1100

参与一下，简单合并。

1. Sub ykcbf()  '//2024.3.12
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set sh = ThisWorkbook.Sheets("汇总")
   
6.     sh.Cells.Clear
   
7.     p = ThisWorkbook.Path & ""
   
8.     For Each f In Fso.GetFolder(p).Files
   
9.         If f.Name Like "*.xls*" Then
   
10.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
11.                 fn = Fso.GetBaseName(f)
    
12.                 Set wb = Workbooks.Open(f, 0)
    
13.                 m = m + 1
    
14.                 With wb.Sheets(1)
    
15.                     If m = 1 Then
    
16.                         .Cells.Copy sh.[a1]
    
17.                     Else
    
18.                         r = sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
    
19.                         .UsedRange.Offset(7).Copy sh.Cells(r, 1)
    
20.                     End If
    
21.                 End With
    
22.                 wb.Close False
    
23.             End If
    
24.         End If
    
25.     Next f
    
26.     With sh
    
27.         r = .Cells(Rows.Count, "a").End(3).Row
    
28.         .UsedRange.Offset(r).Clear
    
29.         For i = 8 To r
    
30.             .Cells(i, 1) = i - 7
    
31.         Next
    
32.     End With
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "合并完毕!"
    
35. End Sub
    

复制代码

ykcbf1100

wfywc81 发表于 2024-3-11 22:29
用ChatGPT花了1分钟写的，请查收！

ChatGPT写的代码并不完全适用，还是需要手工调整一下的。
你这个代码，并没有把标题行复制过去，也就是说，汇总表的标题行必须事先就有才行。