本文于2023年7月31日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！
内容提要
文件合并神器代码
定义变量
Dim savePath As StringDim SaveFile As StringDim dataFolder As StringDim FileSystem As ObjectDim folder As ObjectDim FileExtn As StringDim t As IntegerDim blnCkb As Boolean
自定保存文件名、选择待合并文件所在文件夹
Private Sub CkbName_Click() If Me.CkbName Then Me.TxbTitle.Visible = True Me.TxbTitle = "请输入保存的文件名" Else Me.TxbTitle.Visible = False End IfEnd SubPrivate Sub CmdChoosePath_Click() With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then dataFolder = .SelectedItems(1) Else Exit Sub End If End With Me.TxbTargetPath = dataFolderEnd Sub
确认按钮
Private Sub CmdConfirm_Click() On Error Resume Next Application.ScreenUpdating = False Set FileSystem = CreateObject("Scripting.FileSystemObject") Set folder = FileSystem.GetFolder(dataFolder) If Me.TxbTargetPath = "" Then MsgBox "请选择待合并文件所在文件夹！" Exit Sub Else If FileSystem.folderexists(Me.TxbTargetPath) Then dataFolder = Me.TxbTargetPath Else MsgBox "源文件夹不存在，请重新选择！" Exit Sub End If End If If Me.TxtSavePath = "" Then MsgBox "请选择合并文件保存文件夹！" Exit Sub Else If FileSystem.folderexists(Me.TxtSavePath) Then savePath = Me.TxtSavePath Else MsgBox "目标文件夹不存在，请重新选择！" Exit Sub End If End If If Not wContinue("即将合并文件！") Then Exit Sub If Me.OptExcel Then Call CombineExcel ElseIf Me.OptPDF Then Call CombinePDF ElseIf Me.OptWord Then Call CombineWord ElseIf Me.OptPictureToPDF Then Call CombinePicturesToPDF End If Application.ScreenUpdating = True Shell "explorer.exe " & savePath, vbMaximizedFocus Unload MeEnd Sub
退出、选择保存文件夹、窗体初始化
Private Sub CmdExit_Click() Unload MeEnd SubPrivate Sub CmdChooseSavePath_Click() With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then savePath = .SelectedItems(1) Else Exit Sub End If End With Me.TxtSavePath = savePathEnd SubPrivate Sub UserForm_Initialize() Me.TxtSavePath = ThisWorkbook.path savePath = Me.TxtSavePathEnd Sub
合并EXCEL文件
Private Sub CombineExcel() Dim CombineWs As Worksheet Dim lastRow As Integer, lastCol As Integer Dim rng As Range Dim ws As Worksheet Dim wb As Workbook, CombineWb As Workbook If Me.CkbName Then If Me.TxbTitle = "" Then MsgBox "请输入保存的文件名" Exit Sub End If SaveFile = savePath & "\" & Me.TxbTitle & ".xlsx" Else SaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".xlsx" End If blnCkb = Me.CkbTitle Set CombineWb = Workbooks.Add On Error Resume Next Set CombineWs = CombineWb.Worksheets("合并") On Error GoTo 0 If CombineWs Is Nothing Then Set CombineWs = CombineWb.Worksheets.Add CombineWs.Name = "合并" Else CombineWs.Cells.Clear End If For Each file In folder.Files FileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1)) If FileExtn = ".xlsx" Or FileExtn = ".xls" Then Set wb = Workbooks.Open(file.path) For Each ws In wb.Sheets If t = 0 Then ws.UsedRange.Copy CombineWs.Cells(1, 1) Else lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row lastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column If blnCkb Then Set rng = ws.Range(Cells(2, 1), Cells(lastRow, lastCol)) Else Set rng = ws.Range(Cells(1, 1), Cells(lastRow, lastCol)) End If rng.Copy CombineWs.Cells(CombineWs.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) End If t = t + 1 Next wb.Close savechanges:=False End If Next CombineWb.SaveAs SaveFile CombineWb.Close Set CombineWb = Nothing MsgBox "成功合并【" & t & "】个明细表！"End Sub
合并PDF文件
Private Sub CombinePDF() Dim SinglePDF As Object, CombinePDF As Object Dim pdfName As String Dim pageNum As Long If Me.CkbName Then If Me.TxbTitle = "" Then MsgBox "请输入保存的文件名" Exit Sub End If SaveFile = savePath & "\" & Me.TxbTitle & ".PDF" Else SaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".PDF" End If Set SinglePDF = CreateObject("AcroExch.PDDoc") Set CombinePDF = CreateObject("AcroExch.PDDoc") CombinePDF.Create t = 0 For Each file In folder.Files FileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1)) If FileExtn = ".pdf" Then If SinglePDF.Open(file) Then pageNum = SinglePDF.GetNumPages CombinePDF.InsertPages CombinePDF.GetNumPages - 1, SinglePDF, 0, pageNum, 0 SinglePDF.Close t = t + 1 End If End If Next CombinePDF.Save PDSaveFull, SaveFile CombinePDF.Close Set SinglePDF = Nothing Set CombinePDF = Nothing MsgBox "成功合并【" & t & "】个文件！"End Sub
合并WORD文件
Private Sub CombineWord() Dim WordApp As Object Dim WordDoc As Object Dim wdRng As Object If Me.CkbName Then If Me.TxbTitle = "" Then MsgBox "请输入保存的文件名" Exit Sub End If SaveFile = savePath & "\" & Me.TxbTitle & ".docx" Else SaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".docx" End If Set WordApp = CreateObject("Word.Application") WordApp.Visible = False Set WordDoc = WordApp.Documents.Add t = 0 For Each file In folder.Files FileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1)) If FileExtn = ".doc" Or FileExtn = ".docx" Then WordDoc.Application.Selection.InsertFile file.path, "", False, False WordDoc.Application.Selection.EndKey 6 If Me.CkbPageBreak Then WordDoc.Application.Selection.InsertBreak Type:=7 ' wdPageBreak End If t = t + 1 End If Next WordDoc.SaveAs2 SaveFile, 16 WordDoc.Close WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing MsgBox "成功合并【" & t & "】个文件！"End Sub
合并图片文件为PDF
Private Sub CombinePicturesToPDF() Dim SinglePDF As Object, CombinePDF As Object Dim pdfName As String Dim pageNum As Long If Me.CkbName Then If Me.TxbTitle = "" Then MsgBox "请输入保存的文件名" Exit Sub End If SaveFile = savePath & "\" & Me.TxbTitle & ".PDF" Else SaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".PDF" End If tempFolder = Environ("TEMP") Set SinglePDF = CreateObject("AcroExch.PDDoc") Set CombinePDF = CreateObject("AcroExch.PDDoc") CombinePDF.Create t = 0 For Each file In folder.Files FileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1)) If FileExtn Like ".jpg" Or FileExtn Like ".jpeg" Or FileExtn Like ".png" Or FileExtn Like ".bmp" Then pdfName = ConvertPicToPDF(file, tempFolder) If SinglePDF.Open(pdfName) Then pageNum = SinglePDF.GetNumPages CombinePDF.InsertPages CombinePDF.GetNumPages - 1, SinglePDF, 0, pageNum, 0 SinglePDF.Close End If t = t + 1 End If Next CombinePDF.Save PDSaveFull, SaveFile CombinePDF.Close Set SinglePDF = Nothing Set CombinePDF = Nothing MsgBox "成功合并【" & t & "】个文件！"End Sub
自定义函数取得图片转PDF文件名、确认继续
Function ConvertPicToPDF(picName, pdfPath) As String Dim acroAVDoc As Object Dim newPDF As Object Dim acroApp As Object Dim pdfName As String Set acroApp = CreateObject("AcroExch.App") acroApp.Show Set acroAVDoc = CreateObject("AcroExch.AVDoc") FileExtn = LCase(Right(picName, Len(picName) - InStrRev(picName, ".") + 1)) 'Stop If FileExtn Like ".jpg" Or FileExtn Like ".jpeg" Or FileExtn Like ".png" Or FileExtn Like ".bmp" Then pdfName = Mid(picName, InStrRev(picName, "\") + 1, InStrRev(picName, ".") - InStrRev(picName, "\") - 1) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".pdf" acroAVDoc.Open picName, "Acrobat" Do Until acroAVDoc.IsValid DoEvents Loop Set newPDF = acroAVDoc.GetPDDoc newPDF.Save 1, pdfPath & "\" & pdfName ' 1 is AcroAVDocSaveAsType.acSaveFull newPDF.Close End If acroAVDoc.Close 1 ConvertPicToPDF = pdfPath & "\" & pdfNameEnd FunctionFunction wContinue(Msg) As Boolean '确认继续函数 Dim Config As Long Dim a As Long Config = vbYesNo + vbQuestion + vbDefaultButton2 Ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)继续?" & Chr(10) & Chr(10) & "否(N)退出！", Config) wContinue = Ans = vbYesEnd Function
喜欢就点个赞、点在看、留个言呗！