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

記事ID: 076
タイトル: 【VBA】ファイルをZIP圧縮・解凍する方法（コピペOK）
カテゴリ: ファイル操作
一次キーワード: VBA ZIP 圧縮 解凍
想定読者: 手作業でZIP圧縮してメール添付している事務・管理職
検索意図: VBAでファイルやフォルダをZIP圧縮・解凍する方法を知りたい
読者の悩み（1文）: 毎回手作業でファイルを右クリック→ZIPに圧縮してからメール添付しているのが面倒
読了後にできること（1文）: VBAでファイルやフォルダをZIP圧縮・解凍でき、メール添付の前処理も自動化できる
前提条件:
  - Excel版: Excel 2016以降 / Microsoft 365
  - OS: Windows 10/11
  - 保存形式: .xlsm（マクロ有効ブック）
  - 貼り付け場所: 標準モジュール
  - 実行方法: マクロ実行（F5）またはボタン割り当て
  - その他: 外部ライブラリ不要（Windows標準のShell32を使用）
更新日: 2026-03-11

この記事でわかること

VBAでファイルやフォルダをZIP圧縮・解凍する方法を、コピペで動くコード付きで解説します。

• 対象：手作業でZIP圧縮してメール添付している人、バックアップをZIPで保存したい人
• 所要時間：コピペ → 実行まで3分

完成イメージ

ZIP圧縮の実行前：

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

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内のアイテム数を監視して待機しています
• ファイルのコピー・移動の基本も組み合わせると、圧縮前のファイル整理に便利です

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ファイルをメールに自動添付して送信する方法を参考にしてください
• エラー処理の基本を組み合わせれば、より堅牢なコードにできます

落とし穴

FAQ

Q1: パスワード付きZIPは作れる？

Shell.Applicationではパスワード付きZIPの作成はできません。パスワード付きZIPが必要な場合は、7-Zipのコマンドラインツール（7z.exe）をVBAのShell関数で呼び出す方法があります。

' 例：7-Zipでパスワード付きZIPを作成（7z.exeのインストールが必要）
Shell """C:\Program Files\7-Zip\7z.exe"" a -pMyPassword C:\Data\output.zip C:\Data\報告書\*"

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

まとめ

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

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

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

次にやりたくなること

• Excelファイルをメールに自動添付して送信する方法 — ZIP圧縮したファイルをメール添付する詳細な方法
• 指定フォルダのファイルを自動バックアップする方法 — バックアップファイルをZIP圧縮して保存する組み合わせ

関連記事

• 記事074: vba-file-exists-check
• 記事075: vba-email-attachment
• 記事003: vba-copy-move-files
• 記事061: vba-task-scheduler-auto