VBAツール：【Excel】複数ファイルーファイル毎一括圧縮ツール（Windows標準 zip圧縮）
VBAツール：【Excel】複数ファイルーファイル毎一括圧縮ツール（Windows標準 zip圧縮）

VBAツール：【Excel】複数ファイルーファイル毎一括圧縮ツール（Windows標準 zip圧縮）

VBAツール：【Excel】複数ファイルーファイル毎一括圧縮ツール（Windows標準 zip圧縮）

by chasou_tech · 公開済み 2022年6月20日 · 更新済み 2023年2月10日

  • 複数ファイルを一度にZipで圧縮したいけど、ファイル単位で圧縮ファイルを作りたい。
  • そのために複数ファイルを一つずづ選んで圧縮するのがめんどくさい
  • 会社のPCなので圧縮ソフトをインストールできないので、Windows標準のzipでどうにかしたい
    • 会社のPCの場合、Windows標準以外の圧縮ソフトをインストールできない場合があります。 その場合、たくさんのファイルをファイルごとに圧縮しなければいけないという作業時に、一つずつ選択し、圧縮しなければならず時間と忍耐がかかります。 そんな時に役立つツールをひとまずExcelで作りました。 ◆複数ファイルーファイル毎一括圧縮ツール

    　Excelの見た目はこんな感じでシンプルです。 　複数のファイルを選択すると、ファイルごとに圧縮ファイルが作成されます。 　内容的にVBScriptにした方がいい気もしますが、ひとまずExcelで作りました。

    【使い方】

    (1)「圧縮実行」ボタンを押す (2)ダイアログが開くので、圧縮したいファイルを選択（複数も可能） (3)別のダイアログが開くので、保存先のフォルダを選択 (4)ファイル毎に圧縮が終わると「完了」と出ます。

    サンプルコード VBA サンプルコード Option Explicit Sub Main_圧縮() Dim FilePath() As String Dim FolderPath As String Dim i As Long '//(1)ファイルの指定' If SelectFileDialog(FilePath()) Then Else MsgBox "実行がキャンセルされました。" Exit Sub End If '//(2)保存先の指定' If SelectFolderDialog(FolderPath) Then Else MsgBox "実行がキャンセルされました。" Exit Sub End If '//(3)圧縮' For i = 0 To UBound(FilePath()) Call zip圧縮(FilePath(i), FolderPath) Next MsgBox "完了" End Sub '*********************************************************' '(1)圧縮するファイルの取得' Public Function SelectFileDialog(ByRef FilePath() As String) As Boolean Dim myF As FileDialog Dim i As Long Set myF = Application.FileDialog(msoFileDialogFilePicker) Dim cnt As Long With myF '最初に開く場所(初期フォルダ)の指定。ここではデスクトップにしています。' .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop") '//ダイアログの左上に出てくるタイトル名' .Title = "圧縮するファイルの指定（複数選択可）" '//①Falseはファイル一つ指定、Trueだと複数のファイルの選択が可能になる。' .AllowMultiSelect = True If .Show = True Then 'ダイアログを開く' cnt = .SelectedItems.Count - 1 ReDim FilePath(cnt) '複数ファイルを選択するのをTrueにした場合は全てのファイルのパスを戻します。Falseの場合は単独のファイルのパスのみ戻します。' For i = 1 To .SelectedItems.Count '指定した複数のファイルを配列にして返す' FilePath(i - 1) = .SelectedItems(i) Next i SelectFileDialog = True Else SelectFileDialog = False End If End With Set myF = Nothing End Function '*********************************************************' '(2)保存するフォルダの選択' Public Function SelectFolderDialog(ByRef FolderPath As String) As Boolean Dim myF As FileDialog Set myF = Application.FileDialog(msoFileDialogFolderPicker) With myF '//最初に開く場所(初期フォルダ)の指定。ここではデスクトップにしています。' .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop") '//ダイアログの左上に出てくるタイトル名' .Title = "保存するフォルダの指定" '//保存先フォルダは一つなのでFalseにする' .AllowMultiSelect = False If .Show = True Then 'ダイアログを開く' FolderPath = .SelectedItems(1) '指定したフォルダを返す' SelectFolderDialog = True Else SelectFolderDialog = False End If End With Set myF = Nothing End Function '*********************************************************' '(3)圧縮' Private Sub zip圧縮(ByVal zipTargetPath As String, ByVal FolderPath As String) Dim zipSavePath As String Dim psCommand As String Dim WSH As Object Dim zipResult As Integer Dim zipFolderName As String '//圧縮するフォルダ名orファイル名を取得’ zipFolderName = getLastPathName(zipTargetPath) '//圧縮したzipファイルの保存先' zipSavePath = FolderPath & "\" & zipFolderName '//実行するPowerShellのコマンド作成。「 -Force」で上書き。' psCommand = "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command Compress-Archive -Path " & zipTargetPath & " -DestinationPath " & zipSavePath & " -Force" '" Set WSH = CreateObject("WScript.Shell") '//PowerShellのコマンド実行' '「zipSavePath」で指定した場所に圧縮されます。' zipResult = WSH.Run(Command:=psCommand, WindowStyle:=0, WaitOnReturn:=True) Set WSH = Nothing End Sub '*********************************************************' '//パスの一番最後のフォルダ名orファイル名取得' Function getLastPathName(ByVal zipTargetPath As String) As String Dim FNameArray As Variant Dim lastPathName As String Dim getFileName As String Dim rightPoint As Long Dim chk As Long chk = GetAttr(zipTargetPath) FNameArray = Split(zipTargetPath, "\") '" lastPathName = FNameArray(UBound(FNameArray)) If chk = 16 Then getLastPathName = lastPathName Else '文字列の右端から"."を検索し、左端からの位置を取得する' rightPoint = InStrRev(lastPathName, ".") '拡張子を除いたファイル名の取得' getFileName = Left(lastPathName, rightPoint - 1) getLastPathName = getFileName End If End Function 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155 Option Explicit Sub Main_圧縮()    Dim FilePath() As String    Dim FolderPath As String    Dim i As Long            '//(1)ファイルの指定'    If SelectFileDialog(FilePath()) Then    Else        MsgBox "実行がキャンセルされました。"        Exit Sub    End If        '//(2)保存先の指定'    If SelectFolderDialog(FolderPath) Then    Else        MsgBox "実行がキャンセルされました。"        Exit Sub    End If     '//(3)圧縮'    For i = 0 To UBound(FilePath())        Call zip圧縮(FilePath(i), FolderPath)    Next     MsgBox "完了" End Sub'*********************************************************''(1)圧縮するファイルの取得'Public Function SelectFileDialog(ByRef FilePath() As String) As Boolean     Dim myF As FileDialog    Dim i As Long    Set myF = Application.FileDialog(msoFileDialogFilePicker)        Dim cnt As Long        With myF        '最初に開く場所(初期フォルダ)の指定。ここではデスクトップにしています。'        .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop")         '//ダイアログの左上に出てくるタイトル名'        .Title = "圧縮するファイルの指定（複数選択可）"         '//①Falseはファイル一つ指定、Trueだと複数のファイルの選択が可能になる。'        .AllowMultiSelect = True                        If .Show = True Then 'ダイアログを開く'            cnt = .SelectedItems.Count - 1            ReDim FilePath(cnt)            '複数ファイルを選択するのをTrueにした場合は全てのファイルのパスを戻します。Falseの場合は単独のファイルのパスのみ戻します。'            For i = 1 To .SelectedItems.Count                '指定した複数のファイルを配列にして返す'                FilePath(i - 1) = .SelectedItems(i)            Next i            SelectFileDialog = True        Else            SelectFileDialog = False        End If     End With        Set myF = Nothing End Function'*********************************************************''(2)保存するフォルダの選択'Public Function SelectFolderDialog(ByRef FolderPath As String) As Boolean     Dim myF As FileDialog        Set myF = Application.FileDialog(msoFileDialogFolderPicker)        With myF        '//最初に開く場所(初期フォルダ)の指定。ここではデスクトップにしています。'        .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop")         '//ダイアログの左上に出てくるタイトル名'        .Title = "保存するフォルダの指定"         '//保存先フォルダは一つなのでFalseにする'        .AllowMultiSelect = False         If .Show = True Then 'ダイアログを開く'            FolderPath = .SelectedItems(1) '指定したフォルダを返す'            SelectFolderDialog = True        Else            SelectFolderDialog = False        End If        End With        Set myF = Nothing End Function'*********************************************************''(3)圧縮'Private Sub zip圧縮(ByVal zipTargetPath As String, ByVal FolderPath As String)    Dim zipSavePath As String    Dim psCommand As String    Dim WSH As Object    Dim zipResult As Integer    Dim zipFolderName As String          '//圧縮するフォルダ名orファイル名を取得’    zipFolderName = getLastPathName(zipTargetPath)        '//圧縮したzipファイルの保存先'    zipSavePath = FolderPath & "\" & zipFolderName        '//実行するPowerShellのコマンド作成。「 -Force」で上書き。'    psCommand = "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command  Compress-Archive -Path " & zipTargetPath & " -DestinationPath " & zipSavePath & " -Force"    '"    Set WSH = CreateObject("WScript.Shell")        '//PowerShellのコマンド実行'    '「zipSavePath」で指定した場所に圧縮されます。'    zipResult = WSH.Run(Command:=psCommand, WindowStyle:=0, WaitOnReturn:=True)        Set WSH = Nothing    End Sub'*********************************************************''//パスの一番最後のフォルダ名orファイル名取得'Function getLastPathName(ByVal zipTargetPath As String) As String    Dim FNameArray As Variant    Dim lastPathName As String        Dim getFileName As String    Dim rightPoint As Long     Dim chk As Long        chk = GetAttr(zipTargetPath)            FNameArray = Split(zipTargetPath, "\")    '"        lastPathName = FNameArray(UBound(FNameArray))            If chk = 16 Then        getLastPathName = lastPathName    Else        '文字列の右端から"."を検索し、左端からの位置を取得する'        rightPoint = InStrRev(lastPathName, ".")         '拡張子を除いたファイル名の取得'        getFileName = Left(lastPathName, rightPoint - 1)         getLastPathName = getFileName            End IfEnd Function

    📎📎📎📎📎📎📎📎📎📎