需求:合并文件对于一些用户而言是个常见需求,属于“体力劳动”。往往这个时候,就该VBA出场了。这里,实现了一个带用户界面的文件合并小工具。
功能简述:
1. 用户指定存放有待合并文件的文件夹(文件应该具有相同的结构)
2. 合并好的数据会另存为一个新文件,并且带有时间戳
代码:
Sub Merge() Dim fd As FileDialog Dim forMergeFolder As String Dim used_rows As Long Dim filename As String Dim wb As Workbook Dim currentRow As Long Dim fullFileName As String Dim rng As Range Dim totalRow As Integer Const maxRow As Long = 1048576 Dim r As Long Dim timeStamp As String Dim savedMergeFile As String r = 1 filename = "" Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .AllowMultiSelect = False .Title = "Select the folder to merge" .InitialFileName = "C:\" 'Change local default path here End With If fd.Show = -1 Then forMergeFolder = fd.SelectedItems(1) End If If forMergeFolder = "" Then Exit Sub End If Application.ScreenUpdating = False used_rows = ThisWorkbook.Worksheets("Merged").UsedRange.Rows.Count ThisWorkbook.Worksheets("Merged").Range("A" & (r + 1) & ":" & "Q" & (used_rows + 1)).ClearContents filename = Dir(forMergeFolder & "\*.xls") Do While filename <> "" If filename <> ThisWorkbook.Name And InStr(filename, "MergedData") = 0 Then fullFileName = forMergeFolder & "\" & filename Set rng = Worksheets("Merged").Range("A1048576").End(xlUp).Offset(1, 0) Set wb = GetObject(fullFileName) Set sht = wb.Worksheets(1) used_rows = sht.UsedRange.Rows.Count sht.Range("A6:B" & (used_rows - 1)).Copy ThisWorkbook.Worksheets("Merged").Activate Range("A" & rng.Row).Select Selection.PasteSpecial xlPasteValues sht.Range("D6:H" & (used_rows - 1)).Copy ThisWorkbook.Worksheets("Merged").Range("C" & rng.Row).Select Selection.PasteSpecial xlPasteValues sht.Range("J6:S" & (used_rows - 1)).Copy ThisWorkbook.Worksheets("Merged").Range("H" & rng.Row).Select Selection.PasteSpecial xlPasteValues End If filename = Dir Loop totalRow = Worksheets("Merged").Range("A" & maxRow).End(xlUp).Row Worksheets("Merged").Select Worksheets("Merged").Range("A" & totalRow).Select Sheets("Merged").Copy ChDir forMergeFolder timeStamp = Format(Now, "yyyy-mm-dd hh_mm_ss") savedMergedFile = forMergeFolder & "\" & "MergedData_" & timeStamp & ".xlsx" ActiveWorkbook.SaveAs filename:=savedMergedFile, _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False used_rows = ThisWorkbook.Worksheets("Merged").UsedRange.Rows.Count ThisWorkbook.Worksheets("Merged").Range("A" & (r + 1) & ":" & "Q" & (used_rows + 1)).ClearContents ThisWorkbook.Worksheets("Check").Activate MsgBox ("Merge completed! " & (totalRow - 1) & " rows of raw data in total." & Chr(10) & "Merged data saved as MergedData file.") Application.Workbooks.Open (savedMergedFile) Application.ScreenUpdating = True End Sub
运行结果: