こんにちは！ 健史です。
「Excelシートのある列項目が重複しているデータを探したい！」ということありませんか。
Excelの「COUNTIF 関数」を使えばできますが、処理データを現場にありそうなフォルダ情報から作成し、重複チェックするプログラムを作成してみました。
この記事のプログラムは仕様確認せずにプログラムをご覧頂いても分かりにくく、ご面倒でも「プログラムの作成と実行」を順次読み進めて頂く方が「プログラムを理解する時間」を短縮できると思います、プログラムの内容に至るには時間にして１～２、３分かと思います。
プログラムの作成と実行
今回のサンプルプログラムは
です。
複数のフォルダに同じ名前のファイルがあるかをチェックし、重複してあるものを抽出するプログラムです。
プログラムの概要は以下の通りです。
・シート１にチェック対象となるフォルダを指定する
・シート１のフォルダから、フォルダ名、ファイル名、更新日、サイズをシート２に出力する
・シート２のファイル名で重複しているものがないかチェックし、重複している場合にシート３に出力する
最後の「重複チェック」をExcelで対応する場合は、
・列を追加し、すべての行に'1'(カウント)を入力する
・ピボットテーブルを使い、上記で追加した[カウント]を集計する
・集計した結果「2以上」のファイル名を抽出する
・もとのシートを[ファイル名]でソートしておいて、上記で抽出したファイルを検索する
といった対応でしょうか。
そんな時に対応するプログラムです。
実行までの手順
1.Excelを起動
2.データ入力
Excel2007以降は、Sheet1のみであるためシートを２つ追加し、全部で３つ作成しておきます。
1).シート１にチェック対象となるフォルダのリンク先を入力する
以下は、説明用に作成したフォルダです。
3.Excel-VBAを起動
Altを押した状態でF8キーを押します。
4.[マクロ名(M):]に'test'と入力(''は不要、''内のtestを入力)
5.[作成(C)]をクリック
私はマクロ名を入力したら、そのままEnterを押します。
6.以下のプログラムをドラッグ＆コピー
'フォルダ内すべてを対象にするための定義
Const cnsDIR = "\*.*"
'変数定義
Dim strPath1 As String
Dim strFilename, strFilenameFull As String
Dim ix1, ix2, ix2_t, ix3, ix3_t, ix3_find, iy1, iy1_t, ix1_max, ix2_max As Long
'処理開始
Select Case Sheets.Count 'シート２，シート３を追加し忘れた時の対応
Case 1
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "ワーク"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "リストアップ"
Case 2
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "リストアップ"
End Select
'初期設定 シート２
Sheets(2).Cells.Clear
Sheets(2).Cells(1, 1) = "番号"
Sheets(2).Cells(1, 2) = "フォルダ"
Sheets(2).Cells(1, 3) = "ファイル名"
Sheets(2).Cells(1, 4) = "更新日"
Sheets(2).Cells(1, 5) = "サイズ"
'初期設定 シート３
Sheets(3).Cells.Clear
For iy1 = 1 To 2
iy1_t = (iy1 - 1) * 5
Sheets(3).Cells(1, iy1_t + 1) = "番号" & iy1
Sheets(3).Cells(1, iy1_t + 2) = "フォルダ" & iy1
Sheets(3).Cells(1, iy1_t + 3) = "ファイル名" & iy1
Sheets(3).Cells(1, iy1_t + 4) = "更新日" & iy1
Sheets(3).Cells(1, iy1_t + 5) = "サイズ" & iy1
Next
'シート１に指定した対象フォルダからシート２にファイル情報を取得
ix1_max = Sheets(1).Range("B1").End(xlDown).Row
ix2 = 1
For ix1 = 2 To ix1_max
strPath1 = Sheets(1).Cells(ix1, 2)
' 対象ディレクトリが存在するか、間違えていないかをチェック
If Dir(strPath1, vbDirectory) = "" Then
MsgBox "指定のドキュメントフォルダは存在しません。", vbExclamation
MsgBox (strPath1)
Exit Sub
End If
' 先頭のファイル名の取得
strFilename = Dir(strPath1 & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
Do While strFilename <> ""
' 行を加算
ix2 = ix2 + 1
Sheets(2).Cells(ix2, 1).Value = ix2 - 1
Sheets(2).Cells(ix2, 2).Value = strPath1
Sheets(2).Cells(ix2, 3).Value = strFilename
strFilenameFull = strPath1 & "\" & strFilename
Sheets(2).Cells(ix2, 4) = FileDateTime(strFilenameFull)
Sheets(2).Cells(ix2, 5) = FileLen(strFilenameFull)
' 次のファイル名を取得
strFilename = Dir()
Loop
Next
' シート２の最終行を退避
ix2_max = ix2
'シート２をチェックしシート３に出力する処理
ix3 = 1
For ix2 = 2 To ix2_max - 1
For ix2_t = ix2 + 1 To ix2_max
If Sheets(2).Cells(ix2, 3) = Sheets(2).Cells(ix2_t, 3) Then
' 同じフォルダ名・ファイル名がまだ格納されていないかをチェックする
ix3_find = 0
For ix3_t = 2 To ix3
If Sheets(2).Cells(ix2_t, 2) = Sheets(3).Cells(ix3_t, 7) And _
Sheets(2).Cells(ix2_t, 3) = Sheets(3).Cells(ix3_t, 8) Then
ix3_find = ix3_t
ix3_t = ix3
End If
Next
' 同じフォルダ名・ファイル名がまだ格納されていない場合には、シート３に出力する
If ix3_find = 0 Then
ix3 = ix3 + 1
Sheets(3).Cells(ix3, 1) = Sheets(2).Cells(ix2, 1)
Sheets(3).Cells(ix3, 2) = Sheets(2).Cells(ix2, 2)
Sheets(3).Cells(ix3, 3) = Sheets(2).Cells(ix2, 3)
Sheets(3).Cells(ix3, 4) = Sheets(2).Cells(ix2, 4)
Sheets(3).Cells(ix3, 5) = Sheets(2).Cells(ix2, 5)
Sheets(3).Cells(ix3, 6) = Sheets(2).Cells(ix2_t, 1)
Sheets(3).Cells(ix3, 7) = Sheets(2).Cells(ix2_t, 2)
Sheets(3).Cells(ix3, 8) = Sheets(2).Cells(ix2_t, 3)
Sheets(3).Cells(ix3, 9) = Sheets(2).Cells(ix2_t, 4)
Sheets(3).Cells(ix3, 10) = Sheets(2).Cells(ix2_t, 5)
Sheets(3).Cells(ix3, 4).NumberFormatLocal = "yyyy/m/d"
Sheets(3).Cells(ix3, 9).NumberFormatLocal = "yyyy/m/d"
End If
End If
Next
Next
6.以下に貼り付け(ペースト)
Sub test()
ここに貼り付ける
End Sub
7.F5キーで実行
8.実行結果の確認
Book1に切り替えて下さい。
Altを押した状態でTabキーを押して、Book1に位置づいたらTabキーを離すことで切り替わります。
シート２には、フォルダ・ファイル情報が出力されています。
そして、シート３には、同じファイル名の内容が出力されています。
プログラムの詳細説明
・初期設定シート３の[iy1_t = (iy1 - 1) * 5]について
シート３の列、1～5,6～10をグループとして見出しの最後に'1','2'を付加するためのベースとなる値を計算します。
そして、そのときの[Sheets(3).Cells(1, iy1_t + 1) = "番号" & iy1]は、
iy1=1の時のiy1_tは、(1 -1) × 5 = 0 → 0 + 1 = 1 → "番号1"が1番目の列に入ります
iy1=2の時のiy1_tは、(2 -1) × 5 = 5 → 5 + 1 = 6 → "番号2"が6番目の列に入ります
となります。
ちなみに文字列は'&'で連結できます。
・初期設定シート３を改善
[初期設定シート３]は、[初期設定シート２]と同じ内容をセットしています。
当記事を公開するとき更に効率的にできることは認識していたのですが、反って分かりにくくなってしまうと考えて止めました。
ですが「追記する形であれば比較しながら理解されやすいかも」と考えて改善した内容を紹介します。
変数[iy_t2]をDim文で追加しておきます。
そしてコメントの「初期設定 シート３」部分の処理を以下のように修正します。
'初期設定 シート３
Sheets(3).Cells.Clear
For iy = 1 To 2
iy_t = (iy - 1) * 5
For iy_t2 = 1 To 5
Sheets(3).Cells(1, iy_t + iy_t2) = Sheets(2).Cells(1, iy_t2) & iy
Next
Next
更に記事では[5]になっている部分を変数化し、列数の増減に伴い変数にセットする値を変えるだけで簡単に修正できます。
５つある[番号,フォルダ,ファイル名,更新日,サイズ]に２項目追加した７項目になる場合には、変数[iy_retu]を定義して
'<注意>列数が増減した場合には変更すること
iy_retu = 7
'初期設定 シート３
Sheets(3).Cells.Clear
For iy = 1 To 2
iy_t = (iy - 1) * iy_retu
For iy_t2 = 1 To iy_retu
Sheets(3).Cells(1, iy_t + iy_t2) = Sheets(2).Cells(1, iy_t2) & iy
Next
Next
と修正します。
あまり変数化しすぎると、プログラムを追跡するのがたいへんになる場合もありますから良し悪しあります。
この例では"項目"を増減する頻度(後でプログラムを修正する頻度)が高いようであれば、後からみてもわかるコメントを残した上で変数化し、１度きりその場限りなど低いのであれば変数化しないといった対応が良いと思います。
・Do While strFilename <> "" について
「[Loop]までの処理を[strFilename <> ""]:strFilenameがNullでない間処理する」という意味です。
[strFilename = Dir(strPath1 & cnsDIR, vbNormal)]で1件目のファイル名を取得し、1件もなければnullなので処理は行いません。
1件でもあれば処理を行い、[strFilename = Dir()]で次のファイル名を取得し、なければ条件を満たすので処理は抜けます。
・同じフォルダ名・ファイル名がまだ格納されていないかをチェックする
今回「同じフォルダ名・ファイル名がまだ格納されていないかをチェックする」が無い処理の場合、01.フォルダAから04.フォルダDにも全てに同じファイル名が存在すると、
[１] [２]
①01.フォルダA ファイル1 - 02.フォルダB ファイル1
②01.フォルダA ファイル1 - 03.フォルダC ファイル1
③01.フォルダA ファイル1 - 04.フォルダD ファイル1
④02.フォルダB ファイル1 - 03.フォルダC ファイル1
⑤02.フォルダB ファイル1 - 04.フォルダD ファイル1
⑥03.フォルダC ファイル1 - 04.フォルダD ファイル1
と出力されます。
④～⑥のデータは不要です。
そのためシート３に出力するときに、すでに[１]のフォルダ名・ファイル名が[２]にあれば出力しないようにして、ない場合に出力するようにしました。
もし、すべて出力したい場合には「ix3_find = 0」から「If ix3_find = 0 Then」と連動する「End If」を１行削除します。
フォルダ配下全てからリストアップ
機能追加したプログラムです。
上記で紹介したプログラムは、シート１で指定したフォルダ直下のファイル名が比較対象でした。
ここで紹介するプログラムは、
です。
シート１で指定したフォルダ配下のすべてのファイルが対象になるため、１つしか指定しなかった場合にはそのフォルダ内で同じファイル名が存在する場合、指定フォルダ直下にfile1.txt、指定フォルダ内のサブフォルダ内にfile1.txtが存在する場合には「重複データ」としてピックアップされます。
その更に下のサブフォルダに同じファイル名があれば同様に「重複データ」としてピックアップされます。
プログラムをVBA上に貼り付けるときは、[Sub (test) ～ End Sub]まで全てを削除してから貼り付けます。
作成するプログラム名を例えば'check1'としても、コーディングされている'MAIN00'になります。
変更したい場合は、貼り付けた後に変えるか、事前にメモ帳やサクラエディタなどで変えてから貼り付けます。
'フォルダ内すべてを対象にするための定義
Const cnsDIR = "\*.*"
'変数定義
Dim strPath As String
Dim strFilename, strFilenameFull As String
Dim ix1, ix2, ix2_t, ix3, ix3_t, ix3_find, iy1, iy1_t, ix1_max, ix2_max As Long
Sub MAIN00()
'処理開始
Select Case Sheets.Count 'シート２，シート３を追加し忘れた時の対応
Case 1
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "ワーク"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "リストアップ"
Case 2
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "リストアップ"
End Select
'初期設定 シート２
Sheets(2).Cells.Clear
Sheets(2).Cells(1, 1) = "番号"
Sheets(2).Cells(1, 2) = "フォルダ"
Sheets(2).Cells(1, 3) = "ファイル名"
Sheets(2).Cells(1, 4) = "更新日"
Sheets(2).Cells(1, 5) = "サイズ"
'初期設定 シート３
Sheets(3).Cells.Clear
For iy1 = 1 To 2
iy1_t = (iy1 - 1) * 5
Sheets(3).Cells(1, iy1_t + 1) = "番号" & iy1
Sheets(3).Cells(1, iy1_t + 2) = "フォルダ" & iy1
Sheets(3).Cells(1, iy1_t + 3) = "ファイル名" & iy1
Sheets(3).Cells(1, iy1_t + 4) = "更新日" & iy1
Sheets(3).Cells(1, iy1_t + 5) = "サイズ" & iy1
Next
'シート１に指定した対象フォルダからシート２にファイル情報を取得
ix1_max = Sheets(1).Range("B1").End(xlDown).Row
ix2 = 1
For ix1 = 2 To ix1_max
strPath = Sheets(1).Cells(ix1, 2)
' 対象ディレクトリが存在するか、間違えていないかをチェック
If Dir(strPath, vbDirectory) = "" Then
MsgBox "指定のドキュメントフォルダは存在しません。", vbExclamation
MsgBox (strPath)
Exit Sub
End If
' 先頭のファイル名の取得
Call SUB99_DIRLIST(strPath)
Next
' シート２の最終行を退避
ix2_max = ix2
'シート２をチェックしシート３に出力する処理
ix3 = 1
For ix2 = 2 To ix2_max - 1
For ix2_t = ix2 + 1 To ix2_max
If Sheets(2).Cells(ix2, 3) = Sheets(2).Cells(ix2_t, 3) Then
' 同じフォルダ名・ファイル名がまだ格納されていないかをチェックする
ix3_find = 0
For ix3_t = 2 To ix3
If Sheets(2).Cells(ix2_t, 2) = Sheets(3).Cells(ix3_t, 7) And _
Sheets(2).Cells(ix2_t, 3) = Sheets(3).Cells(ix3_t, 8) Then
ix3_find = ix3_t
ix3_t = ix3
End If
Next
' 同じフォルダ名・ファイル名がまだ格納されていない場合には、シート３に出力する
If ix3_find = 0 Then
ix3 = ix3 + 1
Sheets(3).Cells(ix3, 1) = Sheets(2).Cells(ix2, 1)
Sheets(3).Cells(ix3, 2) = Sheets(2).Cells(ix2, 2)
Sheets(3).Cells(ix3, 3) = Sheets(2).Cells(ix2, 3)
Sheets(3).Cells(ix3, 4) = Sheets(2).Cells(ix2, 4)
Sheets(3).Cells(ix3, 5) = Sheets(2).Cells(ix2, 5)
Sheets(3).Cells(ix3, 6) = Sheets(2).Cells(ix2_t, 1)
Sheets(3).Cells(ix3, 7) = Sheets(2).Cells(ix2_t, 2)
Sheets(3).Cells(ix3, 8) = Sheets(2).Cells(ix2_t, 3)
Sheets(3).Cells(ix3, 9) = Sheets(2).Cells(ix2_t, 4)
Sheets(3).Cells(ix3, 10) = Sheets(2).Cells(ix2_t, 5)
Sheets(3).Cells(ix3, 4).NumberFormatLocal = "yyyy/m/d"
Sheets(3).Cells(ix3, 9).NumberFormatLocal = "yyyy/m/d"
End If
End If
Next
Next
'処理終了
ThisWorkbook.Save
MsgBox "処理終了！"
End Sub
'ディレクトリリスト
Sub SUB99_DIRLIST(ByVal Path As String)
Dim objFile As Object
strFilename = Dir(Path & "\*.*")
Do While strFilename <> ""
ix2 = ix2 + 1
Sheets(2).Cells(ix2, 1).Value = ix2 - 1
Sheets(2).Cells(ix2, 2).Value = Path
Sheets(2).Cells(ix2, 3).Value = strFilename
strFilenameFull = Path & "\" & strFilename
Sheets(2).Cells(ix2, 4) = FileDateTime(strFilenameFull)
Sheets(2).Cells(ix2, 5) = FileLen(strFilenameFull)
strFilename = Dir()
Loop
For Each objFile In CreateObject("Scripting.FileSystemObject").GetFolder(Path).SubFolders
Call SUB99_DIRLIST(objFile.Path)
Next objFile
End Sub
詳細については説明致しません。
最後に
少し長いプログラムになりました。
ですが、この記事を含め紹介しているプログラムはすぐに使えるものです。
基本的な命令だけで、難しい命令は極力使わないように心がけています。
今回の記事で使ったデータは、Windowsのフォルダから持ってくるファイル情報でした。
UNIXなど別OSのフォルダ情報合や手元にある資料データなどの場合には、最初の「Windowsのフォルダから持ってくる」処理は不要であったり、プログラムの内容を変更する必要があります。
手元にあるデータで重複チェックを行いたい場合には、シート２にデータを出力する「Windowsのフォルダから持ってくる」処理を削除します。
そして、見出しやチェックする項目の位置を変更する必要があります。
「Windowsのフォルダから持ってくるファイル情報をチェックする」だけでしか使えないわけではありません。
現場で発生する問題を解決するために、例えば「フォルダの一覧を作成する」といった部分的に使えるものもあり、応用していって頂ければと思います。
プログラムの内容を変更する場合に正常に動作しなくなったら、再度当記事からコピーして、かつ、処理の内容を理解してご対応頂ければ。
尚この記事は、Excel-VBAを起動して貼り付ければ動作することを目指しています。
Excel-VBAの構造、起動方法、実行方法などを理解されていない方は、以下の記事を参照しながら一度やってみてから対応されることをお勧めします。
実行中に発生したエラーの対処法は、上記記事の2.エラーが発生したときの対処法に記載しています。(この段落のリンクから直接遷移します)
コメント