達人養成塾 小川です。
以下のシリーズです。
不要な重複ファイルは自動削除するツールをVBAで自製してみた – Excel マクロ・VBA
サブフォルダすべての中身を調べ、条件に合うファイルを移動させる – Excelマクロ・VBA
で、紹介した、以下のプログラム。
最終的に、見栄えのよい、ネットに晒してもまあいいかな、と思えるくらいまで洗練させたマクロは、こんな感じ↓。
‘Microsoft Scripting Runtime への参照設定をしてください
Sub mydel()
Debug.Print “start”
Dim c As Integer
c = CInt(InputBox(“set max num”))
myMove “.jpg”, c
myMove “.png”, c
Debug.Print “end”
End Sub
Sub myMove(ext As String, mx As Integer)
Dim fs As New Scripting.FileSystemObject
Dim fl(1) As Scripting.File
Dim fBase As String
Dim fname(2) As String
Dim s As String
Dim c As Long
Dim suf As Long
For c = 1 To mx
s = String(4 – Len(CStr(c)), “0”) & c
fBase = ThisWorkbook.path & “\IMG_” & s
fname(0) = fBase & ext
suf = 1
fname(1) = fBase & “-” & suf & ext
Do While fs.FileExists(filespec:=fname(1))
Set fl(0) = fs.GetFile(fname(0))
Set fl(1) = fs.GetFile(fname(1))
If fl(0).DateLastModified = fl(1).DateLastModified And fl(0).Size = fl(1).Size Then
fname(2) = ThisWorkbook.path & “\del\IMG_” & s & “-” & suf & ext
Debug.Print “exists” & vbTab & fname(2)
fs.MoveFile Source:=fname(1), Destination:=fname(2)
End If
suf = suf + 1
fname(1) = fBase & “-” & suf & ext
Loop
Next
For c = LBound(fl) To UBound(fl)
Set fl(c) = Nothing
Next
Set fs = Nothing
End Sub
でも、最初に殴り書きしたものは、こんな感じ↓だったのですね。
（以下、Microsoft Scripting Runtime への参照設定をしてから動かしてください。あと、所定のフォルダはあらかじめ作っておくこと等々いろいろあるが、面倒なのと、今回イイタイコトと直接関係ないので、解説省略（笑 ）
Sub fuga()
Dim fs As Scripting.FileSystemObject
Dim basefolder As Scripting.folder ‘調査対象のフォルダ
Dim mySubFolders As Scripting.Folders ‘調査対象のフォルダ内のすべてのフォルダ
Dim mySubFiles As Scripting.Files ‘調査対象のフォルダ内のすべてのファイル
Dim mySubFolder As Scripting.folder
Dim mySubFile As Scripting.File
Set fs = New Scripting.FileSystemObject
Set basefolder = fs.GetFolder(ThisWorkbook.path)
Set mySubFolders = basefolder.subfolders
For Each mySubFolder In mySubFolders
‘ Debug.Print mySubFolder.Name & ” ” & mySubFolder.DateLastModified
Set mySubFiles = mySubFolder.Files
For Each mySubFile In mySubFiles
‘ Debug.Print mySubFile.Name & ” ” & mySubFile.DateLastModified
Debug.Print mySubFile.path
If mySubFile.Name <> “写真.jpg” & InStr(LCase(mySubFile.Name), “.mov”) Then
fs.MoveFile Source:=mySubFile.path, Destination:=ThisWorkbook.path & “\gather\” & mySubFile.Name
End If
Next
Next
Set mySubFile = Nothing
Set mySubFolder = Nothing
Set mySubFiles = Nothing
Set mySubFolders = Nothing
Set basefolder = Nothing
Set fs = Nothing
End Sub
さてさて、で。
これを基にして、ファイル名が、 IMG_0001.jpg のものから、 IMG_1909.jpg のものまでのすべてについて、
IMG_0001-1.jpg とか、 IMG_0002-2.jpg とかの、ネーミングルールのコピーが存在していないかどうかを調べるよう加工します。
例によって、まずは、動けばいい、ということでテキトーに書きてみる。
IMG_0001-1.jpg
みたいな感じの、 「 -1.jpg 」系でキメウチ。「 -2.jpg 」、「 -3.jpg 」、「 -4.jpg 」 とかは後回し。
そんな難しい問題は、「 -1.jpg 」系が動くようになってから考えることにする。
Sub hogehoge()
Dim fs As Scripting.FileSystemObject
Dim f1 As String, f2 As String
Dim s As String
Dim c As Long
Set fs = New Scripting.FileSystemObject
For c = 1 To 1909
If c < 10 Then '[1-1]
s = “000” & c
ElseIf c < 100 Then
s = “00” & c
ElseIf c < 1000 Then
s = “0” & c
Else
s = c
End If ‘[1-2]
f1 = ThisWorkbook.path & “\IMG_” & s & “.jpg” ‘[2-1]
f2 = ThisWorkbook.path & “\IMG_” & s & “-1.jpg” ‘[2-2]
‘ If fs.FileExists(filespec:=f1) And fs.FileExists(filespec:=f2) Then ‘[3-1]
If fs.FileExists(filespec:=f2) Then ‘[3-2]
fs.MoveFile Source:=f2, Destination:=ThisWorkbook.path & “\del\IMG_” & s & “-1.jpg”
Debug.Print “exists” & vbTab & s
End If
Next
Set fs = Nothing
End Sub
[1-1] ～ [1-2] は、お世辞にも、キレイとは言えないソース。
[2-1] ～ [2-2] も、安直かと。この2つの文字列、途中までかぶっているんだから、もっと洗練させた感じにしたい。
「VBA教えてます」なんて人がサンプルとして晒したら、ちょっと恥ずかしいレベル。
でも、いいんです。自分のために、とりあえず動けばいい！と思って書いているわけですから。
あ、そうだ。
例えて言うと、料理研究家が、自宅で、
「あ～めんどくさ～」
とか言いながらチャーハンでも作っているような感覚です。
僕も、時間のないときにやっつけでマクロ書いているときは、こんな感じなんですよ、ってことが言いたいわけです。
条件分岐は、当初 [3-1] で書いてみたが、その後気が変わって [3-2] で書いてみた。
とはいえ、 [3-1] で書いたのも何かもったいないような気がして、残してある（笑
.jpg で回してみてうまくいったので、次は、 .png ファイルでも同様の処理をするように変更。
これも、まったくやっつけ。主要な部分をコピーして、 .jpg と書かれていた部分を .png に変えただけ。
以下のとおり。
Sub hogehoge()
Dim fs As Scripting.FileSystemObject
Dim f1 As String, f2 As String
Dim s As String
Dim c As Long
Set fs = New Scripting.FileSystemObject
For c = 1 To 1909
If c < 10 Then
s = “000” & c
ElseIf c < 100 Then
s = “00” & c
ElseIf c < 1000 Then
s = “0” & c
Else
s = c
End If
f1 = ThisWorkbook.path & “\IMG_” & s & “.jpg”
f2 = ThisWorkbook.path & “\IMG_” & s & “-1.jpg”
‘ If fs.FileExists(filespec:=f1) And fs.FileExists(filespec:=f2) Then
If fs.FileExists(filespec:=f2) Then
fs.MoveFile Source:=f2, Destination:=ThisWorkbook.path & “\del\IMG_” & s & “-1.jpg”
Debug.Print “exists” & vbTab & s
End If
f1 = ThisWorkbook.path & “\IMG_” & s & “.png”
f2 = ThisWorkbook.path & “\IMG_” & s & “-1.png”
‘ If fs.FileExists(filespec:=f1) And fs.FileExists(filespec:=f2) Then
If fs.FileExists(filespec:=f2) And Not fs.FileExists(ThisWorkbook.path & “\del\IMG_” & s & “-.png”) Then
fs.MoveFile Source:=f2, Destination:=ThisWorkbook.path & “\del\IMG_” & s & “-1.png”
Debug.Print “exists” & vbTab & s
End If
Next
Set fs = Nothing
End Sub
洗練されたコードで書こうとしたら5分くらいかかるかもしれないが、これなら、コピーしたあと、範囲選択し、一括変換すればOK。20秒もかからない。
さっさと、先に行こう。
次はいよいよ、後回しになっていた、「 -2.jpg 」、「 -3.jpg 」、「 -4.jpg 」 とかもキャッチできるように。
..と言っても、これもまたテキトー。
今作ったマクロを For Next 構文で呼び出すようにしてみた。
Sub mycnt()
Dim c As Long
For c = 1 To 10
hoge c
Next
End Sub
Sub hoge(cnt As Long)
Dim fs As Scripting.FileSystemObject
Dim f1 As String, f2 As String
Dim s As String
Dim c As Long
Set fs = New Scripting.FileSystemObject
For c = 1 To 1909
If c < 10 Then
s = “000” & c
ElseIf c < 100 Then
s = “00” & c
ElseIf c < 1000 Then
s = “0” & c
Else
s = c
End If
f1 = ThisWorkbook.path & “\IMG_” & s & “.jpg”
f2 = ThisWorkbook.path & “\IMG_” & s & “-” & cnt & “.jpg”
‘ If fs.FileExists(filespec:=f1) And fs.FileExists(filespec:=f2) Then
If fs.FileExists(filespec:=f2) Then
fs.MoveFile Source:=f2, Destination:=ThisWorkbook.path & “\del\IMG_” & s & “-” & cnt & “.jpg”
Debug.Print “exists” & vbTab & s
End If
f1 = ThisWorkbook.path & “\IMG_” & s & “.png”
&nb
sp; f2 = ThisWorkbook.path & “\IMG_” & s & “-” & cnt & “.png”
‘ If fs.FileExists(filespec:=f1) And fs.FileExists(filespec:=f2) Then
If fs.FileExists(filespec:=f2) And Not fs.FileExists(ThisWorkbook.path & “\del\IMG_” & s & “-” & cnt & “.png”) Then
fs.MoveFile Source:=f2, Destination:=ThisWorkbook.path & “\del\IMG_” & s & “-” & cnt & “.png”
Debug.Print “exists” & vbTab & s
End If
Next
Set fs = Nothing
End Sub
ループのカウンターを 1 to 10 にしたのも、テキトー。
会社の机でこんなマクロを書いて、横に小うるさくてアタマの固い SE の人とかがいたら、
「計算コストが高すぎる」
とか言ってクレームつけてきそうだ。でも、これでいいのである。
どうせ一回きりなんだし。
ということで、以下、まとめ（まとめになっているか分からないけど）
- マクロを書くときは、料理研究家が、自宅で、「あ～めんどくさ～」とか言いながらチャーハンでも作っているような感覚で！
- アタマの固い SE の人とかにクレームつけられそうなマクロでも、気にしない
ということで。
今日は朝早くから仕事なので、このくらいで。次回につづく（笑
