エクセルファイルをグループ毎に圧縮したい

osはwin7,office2010です。
各県の名前が付いたエクセルファイル(.xlsx)があります。毎回全県のファイルは有りませんが、
例えば、四国内の高知.xlsx、香川.xlsx、愛媛.xlsx、徳島.xlsxが存在したら、この4ファイルを四国.zipとしてツールのようなもので圧縮したいです。
また、このうち1県だけや3県など揃っていなくても、四国の県があれば四国.zipとして圧縮したいのです。
この規則で、大阪、東海、中国、四国、九州をツールのようなもので一括処理したいのですが、ｗｅｂを検索してもなかなか見つかりません。
どなたか教えてください。
よろしくお願いいたします。

質問者からの補足コメント

• 質問に追加で、できればexcel VBA でお願いします。

    補足日時：2015/03/10 16:28

No.8 ベストアンサー 回答者： WindFaller 回答日時： 2015/03/11 16:52

追伸：

内容を書き換えて、もう一度、試しましたら、
"-u -j -m "　

で更新されていました。ただ、あれもこれも、ZIP にオプションを付けてはいけないようです。
オプションで進める方針で、設定するなら#6をお使いください。ただし、注意点はオプションの最後にスペースを開けます。
　strCommand = " -u -j "　←j の後ろには、半角スペースが入っています。

今回、私は、ゴミ箱に入れる方も作りました。-m　オプションで格納されるので問題はありません。自分自身だったら、そのまま使っているとかもしれません。今回、細かい所をあちこちと変えましたが、とても細かくて目で追えるとは思えません。

それから、この部分は忘れないでください。
　''※初期条件:パスと拡張子
　Const MYPATH = "C:\Users\[MyName]\My Documents\"　''必ず￥が末尾に来ること
　Const EXT = ".xlsx"
あとは、#6の画像のように、正しい名称、空白を混ぜないで、ワークシートのリストを作ってください。
'------------------------------------------------

'Option Explicit
Private Declare Function Zip Lib "Zip32j" (ByVal hWnd As Integer, ByVal szCmdLine As String, ByVal szOutPut As String, ByVal dwsize As Integer) As Integer
Private Declare Function FindWindow Lib "USER32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SHFileOperation Lib "shell32.dll" _
　　Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Type SHFILEOPSTRUCT
　　hWnd As Long
　　wFunc As Long
　　pFrom As String
　　pTo As String
　　fFlags As Integer
　　fAnyOperationsAborted As Long
　　hNameMappings As Long
　　lpszProgressTitle As String
End Type
Private Const FO_DELETE = &H3&　　　　　　　'削除
Private Const FOF_ALLOWUNDO = &H40&　　　　 'ごみ箱へ
Private Const FOF_NOCONFIRMATION = &H10&　　'確認なし
Private Const FOF_NOERRORUI = &H400&　　　　'エラーを表示しない
Private Const FOF_MULTIDESTFILES = &H1&　　 '複数ファイル指定
'----------------------------
　''※初期条件:パスと拡張子
　Const MYPATH = "C:\Users\[MyName]\My Documents\"　''必ず￥が末尾に来ること
　Const EXT = ".xlsx"
'----------------------------
Sub ボタン1_Click()
　'シートのデータを拾う
　Dim c As Range
　'地域は2行目から作ります。
　For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
　　If c.Value <> "" Then
　　　Call FilesFromArea(c)
　　End If
　Next
　MsgBox "一応終了しましたが、正しくできたか確認してください。", vbInformation
End Sub
Sub FilesFromArea(rng As Range)
　'県名を配列に格納
　Dim i As Variant
　Dim strArea As String
　Dim Prefes As Variant
　　i = rng.Row
　　Prefes = Range(Cells(i, 1), Cells(i, Columns.Count).End(xlToLeft)).Value
　　Prefes = Application.Index(Prefes, 1, 0)
　　Call XlFilesZipArchive(Prefes) '圧縮プログラムへ
End Sub
Sub XlFilesZipArchive(Filenames As Variant)
　'Zip32 による圧縮
　Dim strArchiveName As String
　Dim strCommand As String
　Dim RC As Long
　Dim hWnd As Long
　Dim strOutPut As String * 512
　Dim lngSize As Long
　Dim sDir As String
　Dim dDir As String
　Dim i As Long, j As Long
　Dim fn As String
　Dim origFn As String
　Dim nFilenames As Variant
　'ハンドル取得
　hWnd = FindWindow("XLMANI", Application.Caption)
　sDir = CurDir()　'現在のパス
　ChDir MYPATH　'パス
　'--------削除関連-----------
　Dim lpFileOp As SHFILEOPSTRUCT
　Dim Result　 As Long
　Dim myFlag　 As Long
　Dim Del_files As String
　Dim ret As Long
　
　myFlag = FOF_ALLOWUNDO 'ゴミ箱
　myFlag = myFlag + FOF_NOCONFIRMATION '確認なし
　myFlag = myFlag + FOF_MULTIDESTFILES '複数ファイル

　i = LBound(Filenames)
　ReDim nFilenames(UBound(Filenames) - 1)
　origFn = Filenames(i) '地域名の取得
　j = 0
　For i = LBound(Filenames) + 1 To UBound(Filenames)
　　fn = Dir(Filenames(i) & EXT) '※ここで、実際のファイルの存在を調べる
　　''fn = Dir(MYPATH & Filenames(i) & EXT) 'フォルダー名付き
　　If fn <> "" Then
　　　nFilenames(j) = "" & fn & ""
　　　j = j + 1
　　End If
　Next
　If Len(Join(nFilenames, "")) = 0 Then MsgBox origFn & "のファイルが見つかりません。", vbExclamation: Exit Sub
　strArchiveName = origFn
　''strArchiveName = origFn & Format(Date, "yyyymmdd") & Format(Time, "hm")
　'-----------圧縮の命令----------
　strCommand = " -u -j " & strArchiveName & " " & Join(nFilenames, " ") '　-m　'ZIPオプション
　'オプションは、-u 新規格納, -j フォルダー情報は省く -m 格納後削除
　lngSize = Len(strOutPut)
　RC = Zip(hWnd, strCommand, strOutPut, lngSize)
　ChDir sDir
　If RC <> 0 Then
　　MsgBox origFn & "は正しく格納されていない可能性があります。", vbInformation
　Else
　 If MsgBox(Join(nFilenames, ",") & "を削除してよろしいですか？", vbOKCancel) = vbCancel Then Exit Sub
　'削除の実行
　 Del_files = Join(nFilenames, vbNullChar)
　'構造体に代入
　With lpFileOp
　　.hWnd = hWnd 'ハンドル
　　.wFunc = FO_DELETE ' 削除命令
　　.pFrom = Del_files ' 削除するファイル
　　.fFlags = myFlag '削除方法
　End With
　 ret = SHFileOperation(lpFileOp)
　End If
End Sub

この回答へのお礼

WindFallerさま
昨日、時間を忘れていろいろ試したり、ファイルを間引きして実行させたりと確認しました。
オプションについても外したりなど、こんなことができるということに驚いています。
圧縮の際に、zip32.dllも必要なメッセージが出ましたので、これも入手し追加しました。
すべて思い通りにできています。
なかなか初心者から抜けられないので、またよろしくお願いいたします。
本当にありがとうございました。

お礼日時：2015/03/12 08:49

No.7 回答者： WindFaller 回答日時： 2015/03/11 09:37

こんにちは。

#6の回答者です。

「今、バグにも思える部分としては、」の件について。
>　"-u -j -m "　-u 新規格納, -j フォルダー情報は省く -m 格納後削除
参考：
http://itpro.nikkeibp.co.jp/article/COLUMN/20060 …

http://openlab.ring.gr.jp/tsuneo/soft/zip32j/zip …

本日中に、もう一度、この部分は検討してみます。万が一には、削除したら、ゴミ箱に入れるようなスタイルに変えます。すみません……。

この回答へのお礼

WindFallerさま

お手数おかけしすみません。
ご連絡を待ってそれから加工にかかります。
よろしくお願いいたします。

お礼日時：2015/03/11 10:42

No.6 回答者： WindFaller 回答日時： 2015/03/10 23:50

#5の回答者です。

>ZIPファイルに格納されたファイルについては、不要なので、できれば削除されるとありがたいです。
これは、結果的には、ZIP側にさせることにしました。
　"-u -j -m "　-u 新規格納, -j フォルダー情報は省く -m 格納後削除
ワークシートにリストを作ってください。（添付の画像を参照のこと）

開発タブ－挿入－フォームコントロールのボタンにマクロを登録します。

'※初期条件の、処理するフォルダーと、拡張子です。
　Const MYPATH = "C:\Users\[MyName]\My Documents\"　'末尾は、￥が付きます。
　Const EXT = ".xlsx"

処理するフォルダーというのは、「格納されるファイルがある所のフォルダー」という意味です。
地域の中のひとつでもファイルがあれば、特にエラーメッセージはでません。

今、バグにも思える部分としては、格納したZIPファイルの中に、同じファイル名がありますと、
更新されてないだけでなく、新しいファイルも無くなる可能性があります。
オプションはあっているつもりですが、実行前に、前のZIPファイルはおいていないほうがよいかもしれませんが、そのままでしたら、以下のように、ZIPに識別の年月日でも入れれば、大丈夫のはずです。

この部分に、
''strArchiveName = origFn
strArchiveName = origFn & Format(Date, "yyyymmdd") & Format(Time, "hm")　'日付値が付く

とすれば、[関東201503102337.zip]のようなファイル名になります。
この部分は気をつけてほしいです。

''以下は、実際のコード 2015.03.10
'--標準モジュールの先頭----------------
'Option Explicit　'一応、まだ変更の可能性もありますので、Optionにコメントブロックをいれます。
Private Declare Function Zip Lib "Zip32j" (ByVal hWnd As Integer, ByVal szCmdLine As String, ByVal szOutPut As String, ByVal dwsize As Integer) As Integer
Private Declare Function FindWindow Lib "USER32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'----------------------------
　''※初期条件:パスと拡張子
　Const MYPATH = "C:\Users\[MyName]\My Documents\"　''必ず￥が末尾に来ること
　Const EXT = ".xlsx"
　'----------------------------
　
Sub ボタン1_Click()
　'シートのデータを拾う
　Dim c As Range
　'地域は2行目から作ります。
　For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
　　If c.Value <> "" Then
　　　Call FilesFromArea(c)
　　End If
　Next
　MsgBox "一応終了しましたが、正しくできたか確認してください。", vbInformation
End Sub
Sub FilesFromArea(rng As Range)
　'県名を配列に格納
　Dim i As Variant
　Dim strArea As String
　Dim Prefes As Variant
　　i = rng.Row
　　Prefes = Range(Cells(i, 1), Cells(i, Columns.Count).End(xlToLeft)).Value
　　Prefes = Application.Index(Prefes, 1, 0)
　　Call XlFilesZipArchive(Prefes) '圧縮プログラムへ
End Sub

Sub XlFilesZipArchive(Filenames As Variant)
　'Zip32j.Dll による圧縮
　Dim strArchiveName As String
　Dim strCommand As String
　Dim RC As Long
　Dim hWnd As Long
　Dim strOutPut As String * 512
　Dim lngSize As Long
　Dim sDir As String
　Dim dDir As String
　Dim i As Long, j As Long
　Dim fn As String
　Dim origFn As String
　Dim nFilenames As Variant
　
　'ハンドル取得
　hWnd = FindWindow("XLMANI", Application.Caption)
　sDir = CurDir()
　ChDir MYPATH
　i = LBound(Filenames)
　ReDim nFilenames(UBound(Filenames) - 1)
　origFn = Filenames(i) '地域名の取得
　j = 0
　For i = LBound(Filenames) + 1 To UBound(Filenames)
　　fn = Dir(Filenames(i) & EXT)　'※ここで、実際のファイルの存在を調べる
　　''fn = Dir(MYPATH & Filenames(i) & EXT) 'フォルダー名付き
　　If fn <> "" Then
　　　nFilenames(j) = """" & fn & """"
　　　j = j + 1
　　End If
　Next
　If Len(Join(nFilenames, "")) = 0 Then MsgBox origFn & "のファイルが見つかりません。", vbExclamation: Exit Sub
　strArchiveName = origFn
　''strArchiveName = origFn & Format(Date, "yyyymmdd") & Format(Time, "hm")　'日付値が付く
　'-----------圧縮の命令----------
　strCommand = "-u -j -m " & strArchiveName & " " & Join(nFilenames, " ")
　'オプションは、-u 新規格納, -j フォルダー情報は省く -m 格納後削除
　lngSize = Len(strOutPut)
　RC = Zip(hWnd, strCommand, strOutPut, lngSize)
　ChDir sDir
　If RC <> 0 Then
　　MsgBox origFn & "は正しく格納されていない可能性があります。", vbInformation
　End If
End Sub

この回答へのお礼

WindFallerさま

ありがとうございます。とりあえずリストの作成が完了しましたので、モジュールを貼り付けて加工してみます。

お礼日時：2015/03/11 10:41

No.5 回答者： WindFaller 回答日時： 2015/03/10 20:44

こんばんは。

Excel VBA　マクロでも、そんなにむつかしいことではありませんが、何度もやり直しになるのは嫌ですから、確認させてください。最後、ZIPファイルに格納され、残されたファイルは、どうするのでしょうか？

ボタンをひと押しで、全部のデータを、それぞれの地域にまとめることは可能です。

しかし、この前の質問者さんのように、zipのdllがないとなると、話が振り出しになってしまいます。おまけに、会社に掛けあっても、許可されないとなっていました。Windows内蔵のものは、ものすぐこ使いづらいのです。会社で使うとなると、以下のものでは承認がおりないことがあります。本家のものは有償です。また、アーカイバに内蔵された圧縮ソフトでは、コマンドのみの指示を受けません。

一応、
C:\Windows\System32\ZIP32J.DLL
で行われます。
http://www.vector.co.jp/soft/win95/util/se062163 …

肝心な確認が取れてないままですと、無駄になってしまいます。
どうぞ、ご確認ください。

この回答へのお礼

WindFallerさま

ご連絡ありがとうございます。
進め方について丁寧にご連絡いただき感謝です。
まずは、ZIPファイルに格納されたファイルについては、不要なので、できれば削除されるとありがたいです。
また、DLLについてはフリーソフトなのでＤＬに問題はありません。
とてもワクワクしています。
よろしくお願いいたします。

お礼日時：2015/03/10 20:55

No.4 回答者： kushiroshi 回答日時： 2015/03/10 18:32

ここで解説されているようなもの？

※ファイルを開くダイアログで複数ファイルを選択して ZIP圧縮・解凍
http://makoto-watanabe.main.jp/vba_file0.html

この回答へのお礼

kushiroshiさま
親身にご連絡いただき感謝です。
このページにはたどり着いたのですが、指定した拡張子すべてが対象となるため、地域・県毎の取りまとめについては対応できないようです。
しかしながら、本当に感謝です。ありがとうございます。

お礼日時：2015/03/10 20:58

No.3 回答者： bonaron 回答日時： 2015/03/10 17:19

こちらが参考になると思います。

http://hatenachips.blog34.fc2.com/blog-entry-376 …

実際に使ったことはありませんのであしからず。

この回答へのお礼

bonaronさま

ご連絡いただきありがとうございます。
これも参考になりそうです。
あらかじめ、フォルダを作成し作業するようですね。
できれば、楽ができないかということで、指定した県のファイルをあらかじめ指定した地域名で圧縮　これができないかを探しています。
ありがとうございました。

お礼日時：2015/03/10 21:02

No.2 回答者： 20150201goo 回答日時： 2015/03/10 16:05

ファイルを選択して右クリック→送る→圧縮(zip形式)フォルダをクリックして名前をつけて保存する

この回答へのお礼

20150201gooさま
回答を頂きありがとうございます。
手で圧縮する方法も有りますが、毎日の事なのでできるだけ楽に作業がしたいため、ツール形式で自動で実行される方法を探しています。
ありがとうございました。

お礼日時：2015/03/10 16:12

No.1 回答者： kushiroshi 回答日時： 2015/03/10 15:56

Windows7の機能でZIPフォルダーを作るのではいけないんですか？

http://windows.microsoft.com/ja-jp/windows/compr …

この回答へのお礼

kushirosiさま
回答を頂きありがとうございます。
手で圧縮する方法も有りますが、毎日の事なのでできるだけ楽に作業がしたいため、ツール形式で自動で実行される方法を探しています。
ありがとうございました。

お礼日時：2015/03/10 16:12