達人養成塾 小川です。
いろいろコンテンツ作りとかに没頭しているうちに、ブログの更新か、3日空いてしまいました（汗
続きモノを書いていたのに… (・ω・）
..てか。
そもそも、「僕には、ブログで続きモノを書くなんて、無理なんじゃないか？」かも思いつつ。
今日は、ボチボチ言ってみます。
以下のシリーズです。
不要な重複ファイルは自動削除するツールをVBAで自製してみた – Excel マクロ・VBA
サブフォルダすべての中身を調べ、条件に合うファイルを移動させる – Excelマクロ・VBA
.jpgファイル、.pngファイルを検出して移動させるマクロ – Excel VBA
最終形は、.jpg, .png ファイルで、
IMG_[num]-1.jpg とか、
IMG_[num]-2.jpg とか、
IMG_[num]-3.jpg とか、
そういう名称の複製物を見つけて、削除したい。
そんなニーズに合うマクロを作りました。
（とはいえ、このサンプルでは、いきなり削除するのもなんとなく怖いので、削除予定フォルダに移動させるだけですが）
最終的に、見栄えのよい、ネットに晒してもまあいいかな、と思えるくらいまで洗練させたマクロは、こんな感じ↓。
（動作確認をしたい場合は、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
で、世の人は、人に見せる前に、これをいろいろ見栄え良く修正していくわけです。
以下の状態にまでしてみました。
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”
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
で、今日は、その続きです。
さてさて、で、次は、上記のサブプロシージャ「hoge」の中で、.jpg, .png に対して、まったく同じ処理をしています。
「だったら、この部分をサブルーチンとみなしてしまいたい」とか、いくつか変えてみたい箇所があります。
ということで、以下のようにします。
Sub mycnt()
Dim c As Long
For c = 1 To 10
myMove c, “.jpg”
myMove c, “.png”
Next
End Sub
Sub myMove(cnt As Long, ext As String)
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
For c = 1 To 1909
s = String(4 – Len(CStr(c)), “0”) & c ‘[1]
‘ 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
Debug.Print s
fBase = ThisWorkbook.path & “\IMG_” & s
fname(0) = fBase & ext
fname(1) = fBase & “-” & cnt & ext
fname(2) = ThisWorkbook.path & “\del\IMG_” & s & “-” & cnt & ext
If fs.FileExists(filespec:=fname(1)) Then
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
Debug.Print “exists” & vbTab & s
fs.MoveFile Source:=fname(1), Destination:=fname(2)
End If
End If
Next
Set fs = Nothing
End Sub
まず、メインルーチンのほうで、拡張子も指定するように。
呼び出し先のサブルーチンも、名前を「hoge」から、「myMove」という、それでもいい加減な名前ではあるが、少しは指向性の感じられるものに変更。
あ、あと、[1]で、長さ4桁の数字、すなわち、「0003」とか「0653」とかを作るのを、String関数を使った方法に変更しました。
この関数は、マイナーかも。というか、僕のセミナーでも教えていません。
「マクロ覚えたてのころは、なるべく少ない道具でやれるように」というのが、IBM時代にある先輩から教わって以来の僕の基本方針なんで。
（どういうことか？は、今度書きますね）
そして、
比較元となる、「IMG_[num].jpg」という名前のファイルのフルパス
削除候補の「IMG_[num]_1.jpg」という類の名前のファイルのフルパス
削除対象が移動する先となるフルパス
の3つを、配列に格納することにしました。
さてさて、そんなわけで、いよいよ最後。
この状態のものだと、例えなかったとしても、
IMG_0001-1.jpg
IMG_0001-2.jpg
IMG_0001-3.jpg
IMG_0001-4.jpg
IMG_0001-5.jpg
…
と、
IMG_0001-10.jpg
までのすべてのファイル名称のものを探します。
それでは全体として、処理回数が多すぎる。
てことで、書き直します。
例えば、
IMG_0001-2.jpg
について処理したあと、
IMG_0001-3.jpg
がなかった場合は、すぐに
IMG_0002-1.jpg
を探しにいく、という具合にする。
メインルーチンにあったFor Next構文を、撤廃。
サブルーチンのFor Nextの中に、Do Loop構文を放り込みます。
（Do Loopは、ループに入った段階では何回くり返すか不明なときに使う構文）
Sub mydel()
Debug.Print “start”
Dim c As Integer
c = CInt(InputBox(“set max num”)) ‘[1]
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)) ‘[2-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 ‘[2-2]
Next
For c = LBound(fl) To UBound(fl) ‘[3-1]
Set fl(c) = Nothing
Next ‘[3-2]
Set fs = Nothing
End Sub
↑で、[2-1] ～ [2-2] が、その、Do Loopにした部分。
Do Loopでは、ループに入る前に自分で必要な初期設定をして、ループの中で、自分でカウンター変数の値を変更しなくてはなりません。
そこが For Next 構文とは異なるので注意。
あと、ちょっとカッコつけて、マクロ実行時に、ダイアログで、ファイル名何番までを調査対象としたいのか聞くようにしました。
もちろん、人に見せるんじゃなければ、決してこんなことはしない。ソースの中に直に数値を書き込んで終わりです（笑
あと、[3]で、思い出したように、Scripting.File型で宣言した変数を初期化することにした（笑
..ということで、ようやく、当初お見せしたマクロに至ります。
くり返すが、初心者が世の中に出回っているカッコいいソースコードを上から順になぞっていっても、決して、プログラミングは上達しません。
簡単なところから、ゴチャゴチャと改変していく個々の過程にこそ、学んでもらいたいものがあります。
今回紹介したマクロは初心者には元よりレベルが高すぎるのでソースの中身そのものは理解できないとは思うが、その思想からはいろいろ吸収していただければ、と思っています。
あと、細かいテクニック的には。今回の見どころは…。
- String関数を使って、一定長さの文字列を生成する
- Inputboxの活用法
- Do Loop構文の活用法
てとこでしょうか。
ではでは。
