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)ファイル毎に圧縮が終わると「完了」と出ます。

サンプルコード

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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

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)

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

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

◆複数ファイルーファイル毎一括圧縮ツール

【使い方】

サンプルコード

おすすめ

カテゴリー

プロフィール

Facebook

チャイ専門店　茶窓

Blog＆SNS

写真の販売

【PR】サーバー・PC購入はこちらから

ブログについて

最近の投稿

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

◆複数ファイルーファイル毎一括圧縮ツール

【使い方】

サンプルコード

おすすめ

VBAツール：【Excel】フォルダ容量一括チェックツール

VBA：【DAO】Accessファイルの新規作成

VBA：【Selenium】SeleniumBasicの基本的な使い方。ブラウザの操作、起動と検索

カテゴリー

プロフィール

Facebook

チャイ専門店 茶窓

Blog＆SNS

写真の販売

【PR】サーバー・PC購入はこちらから

ブログについて

最近の投稿

チャイ専門店　茶窓