【VBA】ファイルをZIP圧縮・解凍する方法（コピペOK）

完成イメージ（Before / After）

Before（手動でZIP圧縮）

右クリック→ZIP圧縮を3回繰り返す。

After（VBAで一括ZIP圧縮）

ボタン1つで3フォルダが一括ZIP圧縮。容量も約1/3に。

ZIP圧縮の実行後：

C:\Data\報告書.zip（3ファイルが圧縮された状態）

ZIP解凍の実行前：

C:\Data\報告書.zip

ZIP解凍の実行後：

C:\Data\解凍先\
  ├── 売上報告_2026年1月.xlsx
  ├── 売上報告_2026年2月.xlsx
  └── 売上報告_2026年3月.xlsx

さらに実務版では、フォルダ内のファイルをZIP圧縮してOutlookメールに自動添付するところまで一気に自動化できます。

—

自分も月末に報告書ファイルを10個ずつZIPに圧縮してメール添付する作業を毎月やっていました。右クリック→送る→ZIP、を繰り返すのが本当に面倒でした。

VBAでZIP圧縮を自動化してからは、ボタン1つでZIP化からメール添付までワンクリックでできるようになりました。月末の作業が30分から2分に短縮されたのは大きいです。

同じように手作業でZIP圧縮している人が、この記事でサクッと自動化できるようになればうれしいです。バックアップの自動化と組み合わせる場合は指定フォルダのファイルを自動バックアップする方法も参考になります。

—

最小版：フォルダの中身をZIP圧縮する

まずはフォルダの中身をまとめてZIPファイルに圧縮する最小版です。Windows標準のShell.Applicationを使うので、外部ライブラリのインストールは不要です。

Sub フォルダをZIP圧縮する()
    Dim folderPath As String
    Dim zipPath As String
    Dim sh As Object
    Dim fn As Integer
    Dim i As Integer

    ' --- 圧縮するフォルダのパスを指定 ---
    folderPath = "C:\Data\報告書"

    ' --- 出力するZIPファイルのパスを指定 ---
    zipPath = "C:\Data\報告書.zip"

    ' --- フォルダの存在チェック ---
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "フォルダが見つかりません: " & folderPath, vbExclamation
        Exit Sub
    End If

    ' --- 同名のZIPファイルがあれば削除 ---
    If Dir(zipPath) <> "" Then
        Kill zipPath
    End If

    ' --- 空のZIPファイルを作成（End of Central Directoryレコード: 22バイト） ---
    fn = FreeFile
    Open zipPath For Binary As #fn
    Put #fn, , CByte(&H50)  ' P
    Put #fn, , CByte(&H4B)  ' K
    Put #fn, , CByte(&H5)
    Put #fn, , CByte(&H6)
    For i = 1 To 18
        Put #fn, , CByte(&H0)
    Next i
    Close #fn

    ' --- Shell.ApplicationでフォルダをZIPに圧縮 ---
    Set sh = CreateObject("Shell.Application")
    sh.Namespace(zipPath).CopyHere sh.Namespace(folderPath & "\").Items

    ' --- CopyHereは非同期なので最低1秒待ってからアイテム数を監視 ---
    Application.Wait Now + TimeValue("00:00:01")
    Do Until sh.Namespace(zipPath).Items.Count >= _
             sh.Namespace(folderPath & "\").Items.Count
        Application.Wait Now + TimeValue("00:00:01")
    Loop

    Set sh = Nothing

    MsgBox "ZIP圧縮が完了しました: " & zipPath, vbInformation
End Sub

ポイント：

• Shell.Application はWindows標準のCOMオブジェクトです。CreateObject で利用するので参照設定は不要です
• ZIPファイルは「空のZIPファイルを作成→CopyHereでファイルを追加」という手順で作ります。空のZIPファイルにはZIP形式のEnd of Central Directoryレコード（22バイト）が必要です
• CopyHere は非同期で実行されます。圧縮が完了する前に次の処理に進むと空ZIPになるため、Do Until でZIP内のアイテム数を監視して待機しています
• ファイルのコピー・移動の基本も組み合わせると、圧縮前のファイル整理に便利です

Shell.ApplicationとCopyHereの仕組み

Shell.Application（Shell32）は、Windowsのエクスプローラーが内部的に使っているCOMオブジェクトです。エクスプローラーで右クリック→「送る」→「圧縮(zip形式)フォルダー」を選んだときと同じ処理を、VBAからプログラム的に呼び出しています。Namespace メソッドでフォルダやZIPファイルを「名前空間」として開き、その中のアイテム（ファイルやサブフォルダ）を操作できます。

CopyHere メソッドは、ある名前空間から別の名前空間へアイテムをコピーする命令です。コピー先がZIPファイルの名前空間であれば「圧縮」になり、コピー元がZIPファイルの名前空間であれば「解凍」になります。つまり、圧縮も解凍も内部的には同じCopyHereメソッドを使っており、コピー元とコピー先の組み合わせで動作が変わる仕組みです。なお、CopyHereは非同期で実行されるため、メソッドを呼び出した直後にはまだ処理が完了していません。本記事のコードではDo UntilループでZIP内のアイテム数を監視し、処理の完了を確認しています。

ZIPファイルを解凍する

次に、ZIPファイルを指定したフォルダに解凍するコードです。

Sub ZIPファイルを解凍する()
    Dim zipPath As String
    Dim outputFolder As String
    Dim sh As Object

    ' --- 解凍するZIPファイルのパスを指定 ---
    zipPath = "C:\Data\報告書.zip"

    ' --- 解凍先のフォルダを指定 ---
    outputFolder = "C:\Data\解凍先"

    ' --- ZIPファイルの存在チェック ---
    If Dir(zipPath) = "" Then
        MsgBox "ZIPファイルが見つかりません: " & zipPath, vbExclamation
        Exit Sub
    End If

    ' --- パス末尾のバックスラッシュを補完 ---
    If Right(outputFolder, 1) <> "\" Then
        outputFolder = outputFolder & "\"
    End If

    ' --- 解凍先フォルダがなければ作成 ---
    If Dir(outputFolder, vbDirectory) = "" Then
        MkDir outputFolder
    End If

    ' --- Shell.ApplicationでZIPを解凍 ---
    Set sh = CreateObject("Shell.Application")
    sh.Namespace(outputFolder).CopyHere sh.Namespace(zipPath).Items, &H14

    ' --- CopyHereは非同期なので最低1秒待ってからアイテム数を監視 ---
    Dim itemCount As Long
    itemCount = sh.Namespace(zipPath).Items.Count
    Application.Wait Now + TimeValue("00:00:01")
    Do Until sh.Namespace(outputFolder).Items.Count >= itemCount
        Application.Wait Now + TimeValue("00:00:01")
    Loop

    Set sh = Nothing

    MsgBox "解凍が完了しました: " & outputFolder, vbInformation
End Sub

ポイント：

• 解凍はZIPの中身（Namespace(zipPath).Items）を出力先フォルダにCopyHereするだけです
• CopyHere の第2引数 &H14 は &H4（進捗ダイアログ非表示）+ &H10（上書き確認なし）を合わせたフラグです
• 解凍先フォルダが存在しないとエラーになるため、MkDir で事前に作成しています。フォルダ作成の方法も参考にしてください
• パス末尾のバックスラッシュを自動補完しているため、ユーザーがパスを変更する際に末尾の\を忘れても問題ありません
• 解凍も非同期なので Do Until で待機しています

単一ファイルをZIP圧縮する

フォルダの中身ではなく、ファイル1つだけをZIPに入れたい場合のコードです。

Sub 単一ファイルをZIP圧縮する()
    Dim srcPath As String
    Dim zipPath As String
    Dim sh As Object
    Dim fn As Integer
    Dim i As Integer

    ' --- 圧縮するファイルのパスを指定 ---
    srcPath = "C:\Data\売上報告_2026年3月.xlsx"

    ' --- 出力するZIPファイルのパスを指定 ---
    zipPath = "C:\Data\売上報告_2026年3月.zip"

    ' --- ファイルの存在チェック ---
    If Dir(srcPath) = "" Then
        MsgBox "ファイルが見つかりません: " & srcPath, vbExclamation
        Exit Sub
    End If

    ' --- 同名のZIPファイルがあれば削除 ---
    If Dir(zipPath) <> "" Then
        Kill zipPath
    End If

    ' --- 空のZIPファイルを作成（End of Central Directoryレコード: 22バイト） ---
    fn = FreeFile
    Open zipPath For Binary As #fn
    Put #fn, , CByte(&H50)
    Put #fn, , CByte(&H4B)
    Put #fn, , CByte(&H5)
    Put #fn, , CByte(&H6)
    For i = 1 To 18
        Put #fn, , CByte(&H0)
    Next i
    Close #fn

    ' --- Shell.Applicationでファイルを1つだけZIPに圧縮 ---
    Set sh = CreateObject("Shell.Application")
    sh.Namespace(zipPath).CopyHere srcPath

    ' --- CopyHereは非同期なので最低1秒待ってからアイテム数を監視 ---
    Application.Wait Now + TimeValue("00:00:01")
    Do Until sh.Namespace(zipPath).Items.Count >= 1
        Application.Wait Now + TimeValue("00:00:01")
    Loop

    Set sh = Nothing

    MsgBox "ZIP圧縮が完了しました: " & zipPath, vbInformation
End Sub

ポイント：

• 単一ファイルをZIPに入れる場合は、CopyHere にファイルのパス（文字列）を直接渡します
• フォルダ内の全ファイルをまとめてZIPに入れたい場合は最小版のコード（Namespace(folderPath).Items）を使ってください
• ファイル一覧を取得してから選択的にZIP化したい場合はフォルダ内ファイル一覧を自動取得する方法を参考にしてください

実務版：指定フォルダ内のファイルをZIP圧縮してメール添付する

※ 実行前にブックを上書き保存しておくと安心です。

月末の報告書をZIP圧縮してメール添付するまでをワンクリックで済ませるようにしてからは、月末作業のストレスがなくなりました。

Sub ZIP圧縮してメール添付()
    Dim folderPath As String
    Dim zipPath As String
    Dim sh As Object
    Dim fn As Integer
    Dim i As Integer
    Dim srcItemCount As Long
    Dim olApp As Object
    Dim olMail As Object

    ' --- 圧縮するフォルダのパスを指定 ---
    folderPath = "C:\Data\報告書"

    ' --- 出力するZIPファイルのパスを指定（日付付き） ---
    zipPath = "C:\Data\報告書_" & Format(Date, "yyyymmdd") & ".zip"

    ' --- フォルダの存在チェック ---
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "フォルダが見つかりません: " & folderPath, vbExclamation
        Exit Sub
    End If

    ' --- フォルダが空でないかチェック ---
    If Dir(folderPath & "\*.*") = "" Then
        MsgBox "フォルダにファイルがありません: " & folderPath, vbExclamation
        Exit Sub
    End If

    ' --- 同名のZIPファイルがあれば削除 ---
    If Dir(zipPath) <> "" Then
        Kill zipPath
    End If

    ' ===== STEP1: 空のZIPファイルを作成 =====
    fn = FreeFile
    Open zipPath For Binary As #fn
    Put #fn, , CByte(&H50)  ' P
    Put #fn, , CByte(&H4B)  ' K
    Put #fn, , CByte(&H5)
    Put #fn, , CByte(&H6)
    For i = 1 To 18
        Put #fn, , CByte(&H0)
    Next i
    Close #fn

    ' ===== STEP2: フォルダの中身をZIPに圧縮 =====
    Set sh = CreateObject("Shell.Application")

    srcItemCount = sh.Namespace(folderPath & "\").Items.Count

    sh.Namespace(zipPath).CopyHere sh.Namespace(folderPath & "\").Items

    ' --- CopyHereの完了を待機（最低1秒待ってからアイテム数で監視） ---
    Application.Wait Now + TimeValue("00:00:01")
    Do Until sh.Namespace(zipPath).Items.Count >= srcItemCount
        Application.Wait Now + TimeValue("00:00:01")
    Loop

    ' --- 念のため追加で1秒待機（書き込み完了の確保） ---
    Application.Wait Now + TimeValue("00:00:01")

    Set sh = Nothing

    ' ===== STEP3: Outlookでメール作成＋ZIP添付 =====
    ' Outlookが起動していない場合は自動で起動されます
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0

    If olApp Is Nothing Then
        MsgBox "Outlookを起動できませんでした。ZIPファイルは作成済みです: " & zipPath, vbExclamation
        Exit Sub
    End If

    Set olMail = olApp.CreateItem(0)  ' 0 = olMailItem
    With olMail
        .To = "example@example.com"
        .Subject = "【報告書】" & Format(Date, "yyyy年mm月dd日")
        .Body = "お疲れ様です。" & vbCrLf & vbCrLf & _
                "報告書を添付いたします。" & vbCrLf & _
                "ご確認よろしくお願いいたします。"
        .Attachments.Add zipPath
        .Display  ' プレビュー表示（.Sendに変えると即送信）
    End With

    Set olMail = Nothing
    Set olApp = Nothing

    MsgBox "ZIP圧縮＋メール作成が完了しました", vbInformation
End Sub

ポイント：

• ZIPファイル名に日付を付けています（報告書_20260311.zip）。毎回ユニークなファイル名になるため上書きの心配がありません
• STEP1〜STEP3の3段階構成：空ZIP作成→圧縮→メール添付。各段階でエラーチェックを入れています
• GetObject で既に起動中のOutlookを取得し、なければ CreateObject で新規起動します
• .Display でメールをプレビュー表示しています。内容を確認してから手動で送信できます。.Send に変えると即送信になります
• メール添付の詳細はExcelファイルをメールに自動添付して送信する方法を参考にしてください
• エラー処理の基本を組み合わせれば、より堅牢なコードにできます

落とし穴

VBAでZIP圧縮したファイルの中身が空になるときの対処法

「CopyHereを実行したのにZIPファイルの中身が空」という場合、原因はCopyHereが非同期で実行されるため、圧縮完了前に次の処理に進んでしまうことだ。Do Until sh.Namespace(zipPath).Items.Count >= 期待数 のループで完了を待機してから次の処理を実行する。

VBAでZIP解凍時にパスが見つかりませんエラーが出るときの対処法

「解凍を実行したらパスが見つかりません」というエラーが出る場合、原因は解凍先のフォルダが存在しないことだ。CopyHereは出力先フォルダを自動作成しないため、MkDir で事前にフォルダを作成してから解凍する必要がある。

FAQ

Q1: パスワード付きZIPを作成できますか？

VBA単体（Shell.Application）ではパスワード付きZIPの作成はできません。パスワード付きZIPが必要な場合は、7-Zipのコマンドラインツール（7z.exe）をVBAのShell関数で呼び出す方法が一般的です。7-Zipは無料でインストールでき、AES-256暗号化にも対応しています。Shell実行の方法も参考にしてください。

' 例：7-Zipでパスワード付きZIPを作成（7z.exeのインストールが必要）
Shell """C:\Program Files\7-Zip\7z.exe"" a -pMyPassword -mhe=on C:\Data\output.zip C:\Data\報告書\*"
' -p でパスワード指定、-mhe=on でファイル名も暗号化

なお、7-Zipをインストールしていない環境では実行できないため、社内で配布するマクロの場合は事前に7-Zipのインストールが必要な旨を案内してください。

Q2: ZIPファイルの中身を解凍せずに一覧表示するには？

Shell.Application.Namespace(zipPath).Items でZIP内のアイテムを取得し、ループで名前を列挙できます。

Dim sh As Object, item As Object
Set sh = CreateObject("Shell.Application")
For Each item In sh.Namespace("C:\Data\報告書.zip").Items
    Debug.Print item.Name
Next item

Q3: 複数のファイルを個別にZIP圧縮するには？

Dir関数でファイルを列挙し、ループで1ファイルずつZIP圧縮します。ファイルごとに空ZIPの作成→CopyHere→待機の手順を繰り返してください。フォルダ内ファイル一覧を自動取得する方法も参考になります。

Q4: ZIPの圧縮率を変更できる？

Shell.ApplicationのCopyHereでは圧縮率の指定はできません。Windows標準のZIP機能が使用する圧縮率が自動的に適用されます。圧縮率を変えたい場合は7-Zipなどの外部ツールを使ってください。

Q5: CopyHereの待機がいつまでも終わらない場合は？

Do Untilのループが無限ループになる場合は、タイムアウトを設けてください。

Dim startTime As Date
startTime = Now
Do Until sh.Namespace(zipPath).Items.Count >= srcItemCount
    Application.Wait Now + TimeValue("00:00:01")
    ' 60秒でタイムアウト
    If DateDiff("s", startTime, Now) > 60 Then
        MsgBox "ZIP圧縮がタイムアウトしました", vbExclamation
        Exit Do
    End If
Loop

Q6: ZIP内の特定ファイルだけ解凍できますか？

できます。Shell.Application.Namespace(zipPath).Items でZIP内のファイル一覧を取得し、条件に合うファイルだけをCopyHereで個別に解凍します。

Dim sh As Object, item As Object
Dim outputFolder As String
outputFolder = "C:\Data\解凍先\"

Set sh = CreateObject("Shell.Application")
For Each item In sh.Namespace("C:\Data\報告書.zip").Items
    ' 例：ファイル名に「3月」を含むファイルだけ解凍
    If InStr(item.Name, "3月") > 0 Then
        sh.Namespace(outputFolder).CopyHere item, &H14
    End If
Next item
Set sh = Nothing

ZIP内のファイルをFor Eachで1つずつ確認し、条件に合うものだけCopyHereで取り出す仕組みです。ファイル名だけでなく、item.Sizeでファイルサイズを条件にすることもできます。

まとめ

VBAでファイルやフォルダをZIP圧縮・解凍する方法を紹介しました。

• Shell.Application（Shell32）を使えば外部ライブラリ不要でZIP操作が可能
• CopyHereは非同期処理のため、必ず完了を待機する
• 実務版ではZIP圧縮→メール添付までワンクリックで自動化

バックアップの自動化は指定フォルダのファイルを自動バックアップする方法、解凍先フォルダの作成はフォルダ作成の方法も参考にしてください。

次にやりたくなること

• Excelファイルをメールに自動添付して送信する方法 — ZIPにしたファイルをそのままメール送信したい場合はこちら
• 指定フォルダのファイルを自動バックアップする方法 — バックアップファイルをZIP圧縮して保存する組み合わせ
• PDFを結合・分割する方法 — ZIPに入れる前にPDFを結合しておきたい場合はこちら
• Shell実行の方法 — 7-Zipなどの外部ツールをVBAから呼び出す方法