学以致用——使用VBA合并指定文件夹下的文件（Merge data in the same specified folder）

最新推荐文章于 2024-07-12 13:38:16 发布

预见未来to50

最新推荐文章于 2024-07-12 13:38:16 发布

阅读量1.7k

点赞数

分类专栏：数据分析（Data Analysis）学以致用—实用程序（iApps） Excel技巧及VBA编程（Excel_VBA）

本文链接：https://blog.csdn.net/hpdlzu80100/article/details/80653694

版权

数据分析（Data Analysis）同时被 3 个专栏收录

422 篇文章 39 订阅

订阅专栏

Excel技巧及VBA编程（Excel_VBA）

404 篇文章 171 订阅

订阅专栏

学以致用—实用程序（iApps）

94 篇文章 2 订阅

订阅专栏

需求：合并文件对于一些用户而言是个常见需求，属于“体力劳动”。往往这个时候，就该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

运行结果：