【代码】这个功能有点强悍！合并工作表：按指定字段合并文件夹下所有Excel文件、CSV文件，包含所有子文件夹

Dim sourceFolder As StringDim fileCount As Integer, sheetsCount As Integer, successfulSheetsCount As IntegerDim tbTitle(), wsTarget As Worksheet
Private Sub UserForm_Initialize()    Dim lastRow As Integer, lastCol As Integer    With Me.lbTop        .ZOrder 0        .Visible = False        .Caption = "请输入至少一个共同关键字，2个以上以空格隔开"        .Top = Me.TxbKeyTitles.Top        .Left = Me.TxbKeyTitles.Left        .Height = Me.TxbKeyTitles.Height        .Width = Me.TxbKeyTitles.Width    End With    On Error Resume Next    Set wsTarget = ThisWorkbook.Sheets("汇总")    On Error GoTo 0    If wsTarget Is Nothing Then        MsgBox "不存在工作表“汇总”"        Exit Sub    End IfEnd Sub
Private Sub CkbsheetnameFilter_Change()    If CkbSheetNameFilter Then        Me.FrmSheet.Visible = True    Else        Me.FrmSheet.Visible = False    End IfEnd Sub
Private Sub CkbFileNameFilter_Click()    If Me.CkbFileNameFilter Then        Me.FrmFile.Visible = True    Else        Me.FrmFile.Visible = False    End IfEnd Sub
Private Sub CmdChooseFolder_Click()    Dim preFolder As String    preFolder = Me.TxbFolder    If Not IsFolderExists(preFolder) Then        preFolder = ThisWorkbook.Path    End If    sourceFolder = FolderSelected    If Not sourceFolder = "" Then        Me.TxbFolder = sourceFolder    Else        sourceFolder = preFolder        Me.TxbFolder = sourceFolder    End IfEnd Sub
Private Sub OptNotFirstRow_Change()    If OptNotFirstRow Then        Me.TxbKeyTitles.Visible = True        Me.lbTop.Visible = True        Me.lbTop.ZOrder 0    Else        Me.TxbKeyTitles.Visible = False        Me.lbTop.Visible = False    End IfEnd Sub
Private Sub lbTop_Click()    Me.lbTop.Visible = False    Me.TxbKeyTitles.SetFocusEnd Sub
Private Sub CmdExit_Click()    Unload MeEnd Sub
Private Sub CmdConfirm_Click()    Dim arr(), arrTem(), arrKey() As String    Dim ws As Worksheet, lastRow As Long, lastCol As Long    Dim wb As Workbook, wbTarget As Workbook, rng As Range    Dim dataRow As Integer, titleRow As Integer, itemCount As Integer    Dim FSO As Object, folder As Object, file As Object    Application.ScreenUpdating = False    Application.DisplayAlerts = False    Set FSO = CreateObject("Scripting.FileSystemObject")        '检查一下目标文件夹    If sourceFolder = ThisWorkbook.Path Then        MsgBox "汇总文件夹不能包含本文件:" & ThisWorkbook.Name        Exit Sub    ElseIf Not IsFolderExists(sourceFolder) Then        MsgBox "请正确选择汇总文件夹！"        Exit Sub    End If        If Me.CkbFileNameFilter Then        If Me.TxbFileNameKeyWords = "" Then            MsgBox "请输入文件名关键字！"            Exit Sub        End If    End If    If Me.CkbSheetNameFilter Then        If Me.TxbSheetNameKeyWords = "" Then            MsgBox "请输入工作表名关键字！"            Exit Sub        End If    End If    If Me.OptNotFirstRow Then        If Me.TxbKeyTitles = "" Then            MsgBox "请输入至少一个共同表头字段！"            Exit Sub        End If    End If        With wsTarget        lastRow = .Cells.Find(what:="*", _            lookat:=xlPart, _            LookIn:=xlFormulas, _            searchorder:=xlByRows, _            searchdirection:=xlPrevious).Row        lastCol = .UsedRange.Columns.Count        If lastCol > 1 Then            tbTitle = .Range(.Cells(3, 1), .Cells(3, lastCol)).Value        End If                If lastRow > 3 Then            If Not wContinue("将清除原有数据！") Then Exit Sub            .Range(.Cells(4, 1), .Cells(lastRow, lastCol)).ClearContents        End If            End With    arrTem = Application.Transpose(tbTitle)        '//调用合并递归过程    ProcessFolder sourceFolder, arrTem        '//数据写入工作表    wsTarget.Cells(3, 1).Resize(UBound(arrTem, 2), UBound(arrTem)) = Application.WorksheetFunction.Transpose(arrTem)        Unload Me    MsgBox "文件：" & fileCount & "个;" & Chr(10) _        & "工作表:" & sheetsCount & "个;" & Chr(10) _        & "合并成功:" & successfulSheetsCount & "个。"    Application.ScreenUpdating = True    Application.DisplayAlerts = TrueEnd Sub
Private Sub ProcessFolder(ByVal folderPath As String, ByRef arrTem())    Dim FSO As Object    Dim folder As Object    Dim file As Object    Dim subfolder As Object    Dim colName As String    Dim arr(), i As Long    Dim wb As Workbook    Dim ws As Worksheet, wstemp As Worksheet    Dim preLine As Long, currLine As Long, currCol As Integer        Set FSO = CreateObject("Scripting.FileSystemObject")    Set folder = FSO.GetFolder(folderPath)        For Each file In folder.Files        fileCount = fileCount + 1        fileExtn = LCase(Mid(file.Name, InStrRev(file.Name, ".")))        If fileExtn Like ".xl*" Or fileExtn Like ".csv" And InStr(file.Name, "~$") = 0 Then            On Error Resume Next            If Me.CkbFileNameFilter Then                If Me.OptFileNameInclude Then                    If InStr(file.Name, Me.TxbFileNameKeyWords) > 0 Then                        Set wb = Workbooks.Open(file.Path)                    End If                Else                    If InStr(file.Name, Me.TxbFileNameKeyWords) = 0 Then                        Set wb = Workbooks.Open(file.Path)                    End If                End If            Else                Set wb = Workbooks.Open(file.Path)            End If            On Error GoTo 0            If Not wb Is Nothing Then                wb.Activate                For Each wstemp In wb.Sheets                    sheetsCount = sheetsCount + 1                    If Me.CkbSheetNameFilter Then                        If Me.OptSheetNameInclude Then                            If InStr(wstemp.Name, Me.TxbSheetNameKeyWords) > 0 Then                                Set ws = wstemp                            End If                        Else                            If InStr(wstemp.Name, Me.TxbSheetNameKeyWords) = 0 Then                                Set ws = wstemp                            End If                        End If                    Else                        Set ws = wstemp                    End If                    If Not ws Is Nothing Then                        ws.Activate                        If Me.OptFirstRow Then                            titleRow = 1                            dataRow = 2                        Else                            arrKey = Split(Me.TxbKeyTitles, " ")                            itemCount = 0                            For i = 0 To UBound(arrKey)                                Set rng = Nothing                                On Error Resume Next                                Set rng = ws.Cells.Find(what:=arrKey(i), LookIn:=xlValues, lookat:=xlWhole)                                On Error GoTo 0                                If Not rng Is Nothing Then                                    itemCount = itemCount + 1                                    titleRow = rng.Row                                    dataRow = rng.Row + 1                                End If                            Next                            If itemCount - 1 < UBound(arrKey) Then GoTo NextWorkSheet                        End If                        With ws                            successfulSheetsCount = successfulSheetsCount + 1                            lastCol = .UsedRange.Columns.Count                            'lastRow = .UsedRange.Rows.Count                            lastRow = .Cells.Find(what:="*", _                                lookat:=xlPart, _                                LookIn:=xlFormulas, _                                searchorder:=xlByRows, _                                searchdirection:=xlPrevious).Row                                                        itemCount = 0                            For i = 1 To lastCol                                If .Cells(titleRow, i) <> "" Then                                    itemCount = itemCount + 1                                End If                            Next                            If itemCount > 0 Then                                arr = .Range(.Cells(titleRow, 1), .Cells(lastRow, lastCol))                                preLine = UBound(arrTem, 2)                                currLine = preLine + UBound(arr) - 1                                ReDim Preserve arrTem(1 To UBound(arrTem), 1 To currLine)                                                                '//填上工作簿名、工作表名                                For i = 2 To UBound(arr)                                    arrTem(1, preLine + i - 1) = wb.Name                                    arrTem(2, preLine + i - 1) = ws.Name                                Next                                                                '//合并数据                                For j = 1 To UBound(arrTem)                                    colName = arrTem(j, 1)                                    currCol = Pxy(arr, colName, 2)                                    If currCol > 0 Then                                        For i = 2 To UBound(arr)                                            arrTem(j, preLine + i - 1) = arr(i, currCol)                                        Next                                    End If                                Next                            End If                        End With                        Erase arr                        Set ws = Nothing                    End IfNextWorkSheet:                Next                wb.Close                Set wb = Nothing                            End If        End If    Next        '//如果复选框被选中，递归处理子文件夹    If Me.ChkIncludeSubfolders.Value Then        For Each subfolder In folder.SubFolders            ProcessFolder subfolder.Path, arrTem        Next    End IfEnd Sub

Function wContinue(Msg As String) As Boolean    ' 确认继续函数    Dim Config As VbMsgBoxStyle    Dim ans As VbMsgBoxResult    Config = vbYesNo + vbQuestion + vbDefaultButton2    ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)继续?" & Chr(10) & Chr(10) & "否(N)退出！", Config)    wContinue = (ans = vbYes)End Function
Function FolderSelected(Optional title As String = "请选择文件夹......")    With Application.FileDialog(msoFileDialogFolderPicker)        .title = title        .InitialFileName = ThisWorkbook.Path        If .Show = -1 Then            FolderSelected = .SelectedItems(1)        Else            Exit Function        End If    End WithEnd Function
Function IsFolderExists(strFolder As String) As Boolean    Dim FSO As Object    Set FSO = CreateObject("Scripting.FileSystemObject")    If FSO.folderexists(strFolder) Then        IsFolderExists = True    End IfEnd Function
Function Pxy(arr(), FieldName As String, Optional arrType As Integer = 0)    '**********************************    'arrType=0,表示一维数组    'arrType=1,表示二维数组，查找第一列    'arrType=2,表示二维数组，查找第一行    '**********************************    Dim k As Long, t As Integer    k = 0    t = 0    Select Case arrType    Case Is = 0        For i = LBound(arr) To UBound(arr)            k = k + 1            If arr(i) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 1        For i = LBound(arr, 1) To UBound(arr, 1)            k = k + 1            If arr(i, 1) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 2        For i = LBound(arr, 2) To UBound(arr, 2)            k = k + 1            If arr(1, i) = FieldName Then                t = 1                Exit For            End If        Next    End Select    If t = 1 Then        Pxy = k    Else        Pxy = 0    End IfEnd Function