有多个结构相同的文件,需要合并到一张表中,
如截图中一个文件夹中的文件1、文件2,合并为最终的输出结果:
其结构均相同,如下:
合并后的结构也是如此。
合并提示如下:
程序代码:
程序代码:
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim str As String
Dim strr As String
Dim Str2 As String
Dim cot As Variant
Dim cot1 As Variant
Dim dic As Object
Dim temp
Sheet1.Cells.ClearContents
Application.ScreenUpdating = False
Application.DisplayAlerts = False
temp = ThisWorkbook.Path
objectname = ThisWorkbook.Name '目标文件名
Set fso = CreateObject("Scripting.filesystemobject") '取目标文件
Set myf = fso.getfolder(temp)
c = 0
On Error Resume Next '有错继续
For Each i In myf.Files '开始打开文件
If Right(i.Name, 7) <> Right(objectname, 7) Then '防止重新打开文件打开有重名
Str2 = i.Path
Set wb = GetObject(Str2)
r0 = Sheet1.Range("a65536").End(xlUp).Row '合并的文件行数
c = c + 1
With wb.Sheets(1)
r1 = .Range("a65536").End(xlUp).Row '数文件的行数
c1 = .Range("A1").End(xlToRight).Column '数文件的列数
If c = 1 Then '只有第一个文件取标题
Sheet1.Cells(r0, 1).Resize(r1, c1).Value = .Cells(1, 1).Resize(r1, c1).Value
Else
Sheet1.Cells(r0 + 1, 1).Resize(r1 - 1, c1).Value = .Cells(2, 1).Resize(r1 - 1, c1).Value
End If
End With
End If
wb.Close savechanges:=False
Set wb = Nothing
Next i
MsgBox "成功合并" & c & "个文件"
End Sub