複数のパスワード付きzipに一括で色々なファイルを格納するVBAコード

Sub フォルダ取得()
    
    Dim FSO As Object, WSH As Object
    
    Dim FoldPath As String
    Dim FolderName As String
    Dim ArrFolderName() As String
    
    Dim i As Long, k As Long
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FoldPath = ThisWorkbook.Path

    Cells(1, 2) = FoldPath
    i = 0
    FolderName = Dir(FoldPath & "\*", vbDirectory)
    Do While FolderName <> ""
        If InStr(FolderName, ".") = 0 And FolderName <> "zip格納" Then
            ReDim Preserve ArrFolderName(i)
            ArrFolderName(i) = FolderName
            Cells(i + 4, 1) = FolderName
            'Cells(i + 4, 2) = Left(Cells(i + 4, 1), 4)
            i = i + 1
        End If
    FolderName = Dir()
    Loop
    
End Sub

Sub サブフォルダzip格納()

    Dim Cmd As String
    Dim ArrFileName, FileName
    Dim FSO, WSH
    Dim 前FoldPath, 後FoldPath

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set WSH = CreateObject("Wscript.Shell")

    WSH.CurrentDirectory = "C:\Program Files (x86)\Lhaplus"

    '前FoldPathに格納されているサブフォルダをzip格納して後FoldPathに格納
    前FoldPath = Cells(1, 2)
    後FoldPath = Cells(1, 2) & "\zip格納"

    'zip格納用のフォルダ作成
    If FSO.FolderExists(後FoldPath) = False Then
        FSO.CreateFolder 後FoldPath 'フォルダ作成
    End If

    '後で使用する対象ファイル一覧表が残っていたら削除
    If FSO.FileExists(前FoldPath & "\圧縮リスト.txt") = True Then
        FSO.DeleteFile 前FoldPath & "\圧縮リスト.txt"
    End If

    Dim i
    i = 4
    Do Until Cells(i, 1) = ""
        ArrFileName = ""
        FileName = Dir(前FoldPath & "\" & Cells(i, 1) & "\*.*", vbNormal)
        Do While FileName <> ""
            If ArrFileName <> "" Then
                ArrFileName = ArrFileName & vbCrLf & 前FoldPath & "\" & Cells(i, 1) & "\" & FileName
            Else
                ArrFileName = 前FoldPath & "\" & Cells(i, 1) & "\" & FileName
            End If
        FileName = Dir()
        Loop

        'コマンドプロンプトは文字数の上限があるので、対象ファイル一覧を「圧縮リスト.txt」に入力
        With FSO.CreateTextFile(Cells(1, 2) & "\圧縮リスト.txt")
            .WriteLine ArrFileName
            .Close
        End With

        'cells(i,2)がPassword 空欄ならパスワード設定なしでzip格納
        Cmd = "Lhaplus.exe /c:zip /n:" & 後FoldPath & "\" & Cells(i, 1) & ".zip" & " /p:" & Cells(i, 2).Text & " /l:" & Cells(1, 2) & "\圧縮リスト.txt"

        WSH.Run "%ComSpec% /c " & Cmd, 7, True

        FSO.DeleteFile Cells(1, 2) & "\圧縮リスト.txt"

    i = i + 1
    Loop

    Set FSO = Nothing
    Set WSH = Nothing

End Sub