[EXCEL]分件、转PDF、统计

界面

代码

Option Explicit
Private Sub btn_CP_Click()  '通过创建SHELL对象，调用img2pdf将JPG转为PDF
    
    Dim fs, fol, sub_fol, jpg_path, pdf_path
    Dim WShell As Object
    Dim cp_str As String
    Application.Cursor = xlWait '设置鼠标样式为 忙
    
    Set WShell = CreateObject("WScript.Shell")
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fol = fs.GetFolder(Me.txtPath)
    
    For Each sub_fol In fol.SubFolders
        pdf_path = "D:\PDFConvert\" & sub_fol.Name
        If Not fs.FolderExists(pdf_path) Then fs.CreateFolder (pdf_path)
        For Each jpg_path In sub_fol.SubFolders
            cp_str = "img2pdf -o " & pdf_path & "\" & jpg_path.Name & ".pdf" & jpg_path & "\*.*"    'SHELL命令行命令
            WShell.Run cp_str, 0, True
            Range("A17") = pdf_path & "\" & jpg_path.Name & ".pdf" '信息显示
        Next
    Next
    
    Application.Cursor = xlDefault
    MsgBox "完成！"
    Range("A17") = "完成！"

End Sub

Private Sub btnXZ_Click()
    
    Dim fd As FileDialog
    Me.txtPath = ""
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then
        Me.txtPath = fd.SelectedItems(1)
    End If
    
End Sub

Private Sub btn_tj_Click()
    
    On Error GoTo err_info
    Application.ScreenUpdating = False  '显示刷新：关
    
    Dim fs, fol, qs_fol, qs_fil, iRow, iCount, d, c, i, y, t, se
    Dim b As Range
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fol = fs.GetFolder(Me.txtPath)
    i = 0
    For Each qs_fol In fol.SubFolders
        i = i + 1
        t = 0
        y = 0
        iRow = 0
        iCount = 0
        se = ""
        For Each qs_fil In qs_fol.Files
            Workbooks.Open qs_fil
            iRow = iRow + ActiveSheet.Range("H65536").End(xlUp).Row
            Set b = ActiveSheet.Range("E1:E" & iRow)
            For Each d In b
                se = se & d
            Next
            t = UBound(Split(se, "、"))
            t = t + iRow
            y = y + Application.WorksheetFunction.Sum(ActiveSheet.Range("H1:H" & iRow))
            Workbooks(qs_fil.Name).Close
        Next
        Application.ScreenUpdating = True '显示刷新：开
        '输出结果
        Range("I" & i) = qs_fol.Name
        Range("J" & i) = y
        Range("K" & i) = t
        Application.ScreenUpdating = False  '显示刷新：关
    Next
    Application.ScreenUpdating = True '显示刷新：开
    MsgBox "完成！"

Exit Sub
err_info:
    MsgBox "错误代码：" & Err.Number & vbCrLf & "错误信息：" & Err.Description
    
End Sub

Private Sub btnFJ_Click()
    On Error GoTo err_info
    Application.ScreenUpdating = False '显示刷新：关
    
    Dim fs, fol, fil, sub_fol, i, j, arr(), iRow
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fol = fs.GetFolder(Me.txtPath)
    For Each sub_fol In fol.SubFolders  '遍历子文件夹名
        If Not fs.FileExists(sub_fol & ".xlsx") Then    '根据文件夹查找相对应的excel文件
            MsgBox sub_fol.Name & ".xlsx 文件未找到，请检查！"
            Exit Sub    '无对应文件提示后退出运行
        End If
        Workbooks.Open sub_fol & ".xlsx"
        iRow = ActiveSheet.Range("H65536").End(xlUp).Row
        ReDim arr(iRow - 1)
        For i = 0 To iRow - 1
            arr(i) = ActiveSheet.Range("H" & i + 1)
        Next
        Workbooks(sub_fol.Name & ".xlsx").Close
        Call cp_file(sub_fol, arr())
    Next
    Application.ScreenUpdating = True '显示刷新：开
    MsgBox "完成！"
    Set fs = Nothing
    Set fol = Nothing
    Set fil = Nothing
    Set sub_fol = Nothing

Exit Sub
err_info:
    MsgBox "错误代码：" & Err.Number & vbCrLf & "错误信息：" & Err.Description

End Sub

'--------分件----------
'参数：pic_path  文本：待分件卷的路径
'      arr_number()  数组：页数数据，读取的excel表数据
'----------------------
Private Sub cp_file(pic_path, arr_number())
    On Error GoTo err_info
    Dim tab_count, fil_count, f, i, j, k, fs, fol, s_file, d_path
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fol = fs.GetFolder(pic_path)
    tab_count = Application.Sum(arr_number)
    fil_count = fol.Files.Count
    If tab_count <> fil_count Then
        MsgBox fol.Name & " 录入页数与图片数量不符，请检查！"
        Exit Sub
    End If
    '备份文件夹
    If Not fs.FolderExists(fol.ParentFolder & "_BAK") Then fs.CreateFolder (fol.ParentFolder & "_BAK")
    fs.CopyFolder fol, fol.ParentFolder & "_BAK\"
    '分件
    k = 1
    For Each i In arr_number
        For j = 1 To i
            f = Dir(pic_path & "\*.jpg")
            s_file = pic_path & "\" & f
            d_path = pic_path & "\" & "n" & Format(k, "0000") & "00000"
            fs.MoveFile s_file, d_path & "\" & f
        Next
        k = 1
    Next
    
    Set fs = Nothing
    Set fol = Nothing

Exit Sub
err_info:
    MsgBox "错误代码：" & Err.Number & vbCrLf & "错误信息：" & Err.Description

End Sub

下载地址

https://download.csdn.net/download/gonery/19389342