【ExcelVBA】ZIPファイルの解凍をまとめて連続実行させる

'ZIPファイルを解凍
'引数 szUnzipPath：解凍先のフォルダーのパス
'     szZIPName：ZIPファイルのパス
'     szPWord：パスワード　省略可
'返り値　成功したら True、失敗したらFalse
Public Function DeCompUNZIP(szUnzipPath As String, szZIPName As String, _
                        Optional szPWord As String = "") As Boolean
    Dim szCmd As String
    szCmd = "X " & Cells(11, 9) & " " & Cells(9, 9) & " "
    'szCmd = "X -hide -aoa " '全てのファイルを確認しないで上書き
    'szCmd = "X -hide -aos " '既存のファイルはスキップ
    'szCmd = "X -hide -aou " '解凍するファイルを自動的にリネーム
    'szCmd = "X -hide -aot " '既存のファイルを自動的にリネーム
    If szPWord <> "" Then szCmd = szCmd & "-P" & szPWord & " "
    szCmd = szCmd & dq(szZIPName) & " -o" & dq(szUnzipPath)
    DeCompUNZIP = DoSevenZIP(szCmd) = 0
End Function

'*******************************************
'* 解凍先フォルダ選択指定
'*******************************************
Sub CmdSetFolder()
    Dim n As Long
    Dim re As Long
    
    '「フォルダ選択」ダイアログを表示(modFolderPicker1)
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "解凍先フォルダの参照"
        .AllowMultiSelect = False
        If .Show = False Then
            MsgBox "選択されませんでした"
            Exct Sub
        End If
        'フォルダパスをセルにセット
        Cells(2, 9).Value = .SelectedItems(1)
    End With
End Sub

'*******************************************
'* ZIPファイル解凍実行
'*******************************************
Sub CmdUnZip()
    Dim lngRow As Long          '開始行
    Dim lngRowMax As Long       '最終行
    Dim i As Long               '行指定用
    Dim strFoldFiles As String  '解凍対象フォルダ&ファイル名用
    Dim strDstFullPath As String 'ZIPのフルパス
    Dim strZipName As String    '解凍履歴.txtファイル名用
    Dim strPW As String         'パスワード
    Dim strApndRep As String    '追加or置換
    Dim strErr As String        'エラーメッセージ
    Dim objFSO As FileSystemObject  'FileSystemObject
    Set objFSO = New FileSystemObject
    
    '7-Zip.dllのパス設定（Systmに無い場合のため）
    ChDrive ThisWorkbook.path
    ChDir ThisWorkbook.path
    
    lngRowMax = Cells(Rows.Count, 2).End(xlUp).Row '対象データ最終行
    lngRow = 2  'データ開始行
        
    '解凍先フォルダパス
    strDstFullPath = Trim(Cells(2, 9).Value)
    strZipName = "解凍履歴"
    '追加or置換判定（置換の場合ZIPファイルを削除）
    strApndRep = Cells(5, 9).Value
    If strApndRep = "置換" Then
        On Error Resume Next
        objFSO.DeleteFile strDstFullPath & "\*", True
        objFSO.DeleteFolder strDstFullPath & "\*", True
        If Err.Number <> 0 Then
            strErr = "解凍先フォルダ内ファイル等の事前削除に失敗！" _
                        & vbCrLf & Err.Description
            Err.Clear
            On Error GoTo 0
            Set objFSO = Nothing
            Exit Sub
        End If
        On Error GoTo 0
    End If
    'ログ用txtファイル見出し
    strcmd = "cmd　sw1　sw2　sw3 PW ZIPファイル名 Path/FileName"
    '解凍対象数分のループ処理
    For i = lngRow To lngRowMax
        '対象フォルダ&ZIPファイルの存在確認
        strFoldFiles = Trim(Cells(i, 2).Value)
        If Not objFSO.FileExists(strFoldFiles) Then
            If objFSO.FolderExists(strFoldFiles) Then
                'フォルダ指定はフォルダ内の全てのZIPを
                strFoldFiles = strFoldFiles & "\*.zip"
            Else
                strErr = "対象が存在しません。" _
                                & vbCrLf & strFoldFiles
                Set objFSO = Nothing
                Exit Sub
            End If
        End If
        'パスワード（個別設定を優先する）
        strPW = Trim(Cells(i, 7).Value)
        If strPW = "" Then strPW = Trim(Cells(7, 9).Value)
        '-------------------------------------------
        '7-Zip.dllの処理へ（解凍先フォルダ、ZIPファイル、PW)
        Call DeCompUNZIP(strDstFullPath, strFoldFiles, strPW)
        '-------------------------------------------
    Next
    '解凍実行後ログをテキストファイルに書き出す
    Dim strPath As String
    strPath = strDstFullPath & strZipName & ".txt"
    strcmd = strcmd & vbCrLf & "解凍処理日時：" & Now
    With objFSO
        If Not .FileExists(strPath) Then
            .CreateTextFile (strPath)
        End If
        With .OpenTextFile(strPath, 8) '8:ForAppending
            .WriteLine strcmd
            .Close
        End With
    End With
    Set objFSO = Nothing
    MsgBox "ZIPファイルの解凍処理が完了しました！" & vbCrLf & _
            "復元したファイルを確認してください。"
End Sub