VBA选择合并文件夹下excel文件

Sub 合并文件()
    sheetsNum = Sheets.Count
    
    '新建一个对话框对象
    Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker)
    
    '配置对话框
    With FolderDialogObject
        .Title = "请选择要查找的文件夹"
    End With
    
    '显示对话框
    FolderDialogObject.Show
    
    '获取选择对话框选择的文件夹
    Set paths = FolderDialogObject.SelectedItems
    
    If paths.Count = 0 Then
        MsgBox "未选中任何文件夹，退出"
        Exit Sub
    End If
    
    '获取文件夹下面的所有文件
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFiles = fso.GetFolder(paths(1))
    If Not objFiles Is Nothing Then
        For Each objFile In objFiles.Files
            If InStr(objFile.Name, "~$") < 1 And InStr(objFile.Name, ".xls") > 0 Then
                'copy选中文件的sheet至主文件中
                CopyFileSheets (objFile)
            End If
        Next
    End If
    
    Call 合并工作表(sheetsNum)
    
End Sub
Sub 合并工作簿()
    sheetsNum = Sheets.Count
    Dim FileOpen
    Dim X As Integer
    Application.ScreenUpdating = False
    FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Office Excel 文件(*.*),*xls,Microsoft Excel文件(*.xlsx),*.xlsx", MultiSelect:=True, Title:="请选择需要合并的工作簿")
    X = 1
    If TypeName(FileOpen) = "Boolean" Then
        MsgBox "未选择任何文件, 退出."
        Exit Sub
    End If
    While X <= UBound(FileOpen)
        CopyFileSheets (FileOpen(X))
        X = X + 1
    Wend
    
    Call 合并工作表(sheetsNum)
    '删除生成的sheets
    'Application.DisplayAlerts = False   '关闭删除时的弹框提示
    
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

errhadler:
    MsgBox Err.Description
End Sub
Sub 合并工作表(sheetsNum)
    ThisWorkbook.Activate
    Dim J As Integer
    
    Dim pjMainSheetName As String
    For sheetNum = 1 To sheetsNum
        If InStr(Sheets(sheetNum).Name, "动态销售定价表") > 0 And InStr(Sheets(sheetNum).Name, "说明") < 1 Then
            pjMainSheetName = Sheets(sheetNum).Name
            Exit For
        End If
    Next
    
    On Error Resume Next
    Sheets(pjMainSheetName).Activate
    Range("A6").EntireRow.Select
    
    '获取合并前所有的项目信息
    Dim pjNameDic
    Set pjNameDic = CreateObject("Scripting.Dictionary")
    
    mainSheetRow = Sheets(pjMainSheetName).Range("A65536").End(xlUp).Row
    ReDim pjNameArray(mainSheetRow)
    For itemRow = 7 To mainSheetRow
        '将第一列第二列第三列的值作为一个主键值
        pjNameDic.Add Cells(itemRow, 2) & Cells(itemRow, 3) & Cells(itemRow, 4) & Cells(itemRow, 5), itemRow
    Next
    
    '遍历sheet，将所有sheet的值copy至主excel中
    For J = sheetsNum + 1 To Sheets.Count
        Sheets(J).Activate
        c = Sheets(J).Range("IV7").End(xlToLeft).Column
        r = Sheets(J).Range("A65536").End(xlUp).Row
        Number = 1
        '循环遍历sheet中的行
        For Row = 7 To r
            '判断是否重复的主键
            pjKey = Cells(Row, 2) & Cells(Row, 3) & Cells(Row, 4) & Cells(Row, 5)
            If pjNameDic.Item(pjKey) < 1 Then
                '主sheet统计栏上面中添加一行空行
                Sheets(pjMainSheetName).Rows(Sheets(pjMainSheetName).Range("A65536").End(xlUp).Row + 1).Insert
                '如果字典中不存在，则在主sheet中添加一行，并加入到字典中
                Range(Row & ":" & Row).Resize(1, c).Select
                Application.DisplayAlerts = False   '关闭弹框提示
                Selection.Copy Destination:=Sheets(pjMainSheetName).Range("A65536").End(xlUp)(2)
                
                pjNameDic.Add pjKey, mainSheetRow + Number
                Number = Number + 1
            Else
                '更新存在的列
                For col = 7 To c
                    cellValue = Cells(Row, col)
                    Sheets(pjMainSheetName).Activate
                    Cells(pjNameDic.Item(pjKey), col) = cellValue
                    Sheets(J).Activate
                Next
            End If
        Next
    Next
End Sub
Sub CopyFileSheets(fileNamePath)
    Workbooks.Open Filename:=fileNamePath
    
    '获取需要合并的工作簿的序号，放入数组中
    Count = 0
    For i = 1 To Sheets.Count
        If InStr(Sheets(i).Name, "说明") < 1 And InStr(Sheets(i).Name, "动态销售定价表") > 0 Then
            Count = Count + 1
        End If
    Next
    
    If Count > 0 Then
        Dim sheetArray
        ReDim sheetArray(Count - 1)
        num = 0
        For i = 1 To Sheets.Count
            If InStr(Sheets(i).Name, "说明") < 1 And InStr(Sheets(i).Name, "动态销售定价表") > 0 Then
                sheetArray(num) = i
                num = num + 1
            End If
        Next
        Application.DisplayAlerts = False
        'copy sheet to main excel file
        Sheets(sheetArray).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    End If
End Sub

 

转载于:https://my.oschina.net/kousm/blog/2252126