こんにちは！ 健史です。
「Excelシートのある列項目が重複しているデータを探したい！」ということありませんか。
Excelの「COUNTIF 関数」を使えばできますが、処理データを現場にありそうなフォルダ情報から作成し、重複チェックするプログラムを作成してみました。
この記事のプログラムは仕様確認せずにプログラムをご覧頂いても分かりにくく、ご面倒でも「プログラムの作成と実行」を順次読み進めて頂く方が「プログラムを理解する時間」を短縮できると思います、プログラムの内容に至るには時間にして１～２、３分かと思います。
尚この記事は、Excel-VBAを起動して貼り付ければ動作することを目指しています。
Excel-VBAの構造、起動方法、実行方法などを理解されていない方は、以下の記事を参照しながら一度やってみてから対応されることをお勧めします。
実行中に発生したエラーの対処法は、上記記事の2.エラーが発生したときの対処法に記載しています。(この段落のリンクから直接遷移します)
プログラムの作成と実行
今回のサンプルプログラムは
です。
複数のフォルダに同じ名前のファイルがあるかをチェックし、重複してあるものを抽出するプログラムです。
プログラムの概要は以下の通りです。
・シート１にチェック対象となるフォルダを指定する
・シート１のフォルダから、フォルダ名、ファイル名、更新日、サイズをシート２に出力する
・シート２のファイル名で重複しているものがないかチェックし、重複している場合にシート３に出力する
最後の「重複チェック」を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 i1, i2, i2_t, i3, i3_t, i3_find, j, j_t As Long
Dim last_row1, last_row2 As Long
'初期設定 シート２
Worksheets(2).Cells.Clear
Worksheets(2).Cells(1, 1) = "番号"
Worksheets(2).Cells(1, 2) = "フォルダ"
Worksheets(2).Cells(1, 3) = "ファイル名"
Worksheets(2).Cells(1, 4) = "更新日"
Worksheets(2).Cells(1, 5) = "サイズ"
'初期設定 シート３
Worksheets(3).Cells.Clear
For j = 1 To 2
j_t = (j - 1) * 5
Worksheets(3).Cells(1, j_t + 1) = "番号" & j
Worksheets(3).Cells(1, j_t + 2) = "フォルダ" & j
Worksheets(3).Cells(1, j_t + 3) = "ファイル名" & j
Worksheets(3).Cells(1, j_t + 4) = "更新日" & j
Worksheets(3).Cells(1, j_t + 5) = "サイズ" & j
Next
'シート１に指定した対象フォルダからシート２にファイル情報を取得
last_row1 = Worksheets(1).Range("B1").End(xlDown).Row
i2 = 1
For i1 = 2 To last_row1
strPath1 = Worksheets(1).Cells(i1, 2)
' 対象ディレクトリが存在するか、間違えていないかをチェック
If Dir(strPath1, vbDirectory) = "" Then
MsgBox "指定のドキュメントフォルダは存在しません。", vbExclamation
MsgBox (strPath1)
Exit Sub
End If
' 先頭のファイル名の取得
strFilename = Dir(strPath1 & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
Do While strFilename <> ""
' 行を加算
i2 = i2 + 1
Worksheets(2).Cells(i2, 1).Value = i2 - 1
Worksheets(2).Cells(i2, 2).Value = strPath1
Worksheets(2).Cells(i2, 3).Value = strFilename
strFilenameFull = strPath1 & "\" & strFilename
Worksheets(2).Cells(i2, 4) = FileDateTime(strFilenameFull)
Worksheets(2).Cells(i2, 5) = FileLen(strFilenameFull)
' 次のファイル名を取得
strFilename = Dir()
Loop
Next
' シート２の最終行を退避
last_row2 = i2
'シート２をチェックしシート３に出力する処理
i3 = 1
For i2 = 2 To last_row2 - 1
For i2_t = i2 + 1 To last_row2
If Worksheets(2).Cells(i2, 3) = Worksheets(2).Cells(i2_t, 3) Then
' 同じフォルダ名・ファイル名がまだ格納されていないかをチェックする
i3_find = 0
For i3_t = 2 To i3
If Worksheets(2).Cells(i2_t, 2) = Worksheets(3).Cells(i3_t, 7) And _
Worksheets(2).Cells(i2_t, 3) = Worksheets(3).Cells(i3_t, 8) Then
i3_find = i3_t
i3_t = i3
End If
Next
' 同じフォルダ名・ファイル名がまだ格納されていない場合には、シート３に出力する
If i3_find = 0 Then
i3 = i3 + 1
Worksheets(3).Cells(i3, 1) = Worksheets(2).Cells(i2, 1)
Worksheets(3).Cells(i3, 2) = Worksheets(2).Cells(i2, 2)
Worksheets(3).Cells(i3, 3) = Worksheets(2).Cells(i2, 3)
Worksheets(3).Cells(i3, 4) = Worksheets(2).Cells(i2, 4)
Worksheets(3).Cells(i3, 5) = Worksheets(2).Cells(i2, 5)
Worksheets(3).Cells(i3, 6) = Worksheets(2).Cells(i2_t, 1)
Worksheets(3).Cells(i3, 7) = Worksheets(2).Cells(i2_t, 2)
Worksheets(3).Cells(i3, 8) = Worksheets(2).Cells(i2_t, 3)
Worksheets(3).Cells(i3, 9) = Worksheets(2).Cells(i2_t, 4)
Worksheets(3).Cells(i3, 10) = Worksheets(2).Cells(i2_t, 5)
Worksheets(3).Cells(i3, 4).NumberFormatLocal = "yyyy/m/d"
Worksheets(3).Cells(i3, 9).NumberFormatLocal = "yyyy/m/d"
End If
End If
Next
Next
6.以下に貼り付け(ペースト)
Sub test()
ここに貼り付ける
End Sub
7.F5キーで実行
8.実行結果の確認
Book1に切り替えて下さい。
Altを押した状態でTabキーを押して、Book1に位置づいたらTabキーを離すことで切り替わります。
シート２には、フォルダ・ファイル情報が出力されています。
そして、シート３には、同じファイル名の内容が出力されています。
フローチャート
[For～Next]の部分だけですが、以下の記事のフローチャートを参照下さい。
変数名と処理回数が異なりますが、処理形式[For～Next]の中に[For～Next]は同じです。
今回は[For～Next]の中に[For～Next]さらにもう1回[For～Next]がある形です。
プログラムの詳細説明
上記フロー同様、プログラムの説明も以下の記事を参照下さい。
上記記事にない部分を追記します。
'フォルダ内すべてを対象にするための定義
Const cnsDIR = "\*.*"
フォルダから抽出する対象ファイルを指定する
*.*と指定することで「すべてのファイルのすべての拡張子」になります
'変数定義
Dim strPath1 As String
Dim strFilename, strFilenameFull As String
Dim i1, i2, i2_t, i3, i3_t, i3_find, j, j_t As Long
Dim last_row1, last_row2 As Long
'初期設定 シート２
Worksheets(2).Cells.Clear
Worksheets(2).Cells(1, 1) = "番号"
Worksheets(2).Cells(1, 2) = "フォルダ"
Worksheets(2).Cells(1, 3) = "ファイル名"
Worksheets(2).Cells(1, 4) = "更新日"
Worksheets(2).Cells(1, 5) = "サイズ"
'初期設定 シート３
Worksheets(3).Cells.Clear
For j = 1 To 2
j_t = (j - 1) * 5
シート３の見出し項目が5個あるということ
以下の項目が7個になった場合には、個々の値も7に変えます。
Worksheets(3).Cells(1, j_t + 1) = "番号" & j
Worksheets(3).Cells(1, j_t + 2) = "フォルダ" & j
Worksheets(3).Cells(1, j_t + 3) = "ファイル名" & j
Worksheets(3).Cells(1, j_t + 4) = "更新日" & j
Worksheets(3).Cells(1, j_t + 5) = "サイズ" & j
Next
'シート１に指定した対象フォルダからシート２にファイル情報を取得
last_row1 = Worksheets(1).Range("B1").End(xlDown).Row
i2 = 1
For i1 = 2 To last_row1
strPath1 = Worksheets(1).Cells(i1, 2)
以下で参照するファルダ名が長くなってしまうのでstrPath1にセット
' 対象ディレクトリが存在するか、間違えていないかをチェック
If Dir(strPath1, vbDirectory) = "" Then
シート１で指定したフォルダが存在するかをチェックするIf文
MsgBox "指定のドキュメントフォルダは存在しません。", vbExclamation
MsgBox (strPath1)
Exit Sub
存在しなかったらメッセージを表示して処理を終了する
End If
' 先頭のファイル名の取得
strFilename = Dir(strPath1 & cnsDIR, vbNormal)
1件目ではstrFilenameには[G:\01.フォルダA\*.*]の指定で読み込んだファイル名が入る
' ファイルが見つからなくなるまで繰り返す
Do While strFilename <> ""
' 行を加算
i2 = i2 + 1
Worksheets(2).Cells(i2, 1).Value = i2 - 1
Worksheets(2).Cells(i2, 2).Value = strPath1
Worksheets(2).Cells(i2, 3).Value = strFilename
strFilenameFull = strPath1 & "\" & strFilename
1件目ではstrFilenameFullには[G:\01.フォルダA\ファイル11.txt]が入る
Worksheets(2).Cells(i2, 4) = FileDateTime(strFilenameFull)
最終更新日をセット
Worksheets(2).Cells(i2, 5) = FileLen(strFilenameFull)
サイズをセット
' 次のファイル名を取得
strFilename = Dir()
Loop
Next
' シート２の最終行を退避
last_row2 = i2
'シート２をチェックしシート３に出力する処理
i3 = 1
For i2 = 2 To last_row2 - 1
シート２の最終行の1つ前までをベースに比較処理を行うため
For i2_t = i2 + 1 To last_row2
i2を固定しておきi2の次から最終行までを対象に比較処理を行うため
If Worksheets(2).Cells(i2, 3) = Worksheets(2).Cells(i2_t, 3) Then
2番目と3番目、2番目と4番目と比較し同じものがあったら
' 同じフォルダ名・ファイル名がまだ格納されていないかをチェックする
i3_find = 0
For i3_t = 2 To i3
If Worksheets(2).Cells(i2_t, 2) = Worksheets(3).Cells(i3_t, 7) And _
Worksheets(2).Cells(i2_t, 3) = Worksheets(3).Cells(i3_t, 8) Then
i3_find = i3_t
i3_t = i3
End If
Next
' 同じフォルダ名・ファイル名がまだ格納されていない場合には、シート３に出力する
If i3_find = 0 Then
i3 = i3 + 1
Worksheets(3).Cells(i3, 1) = Worksheets(2).Cells(i2, 1)
Worksheets(3).Cells(i3, 2) = Worksheets(2).Cells(i2, 2)
Worksheets(3).Cells(i3, 3) = Worksheets(2).Cells(i2, 3)
Worksheets(3).Cells(i3, 4) = Worksheets(2).Cells(i2, 4)
Worksheets(3).Cells(i3, 5) = Worksheets(2).Cells(i2, 5)
Worksheets(3).Cells(i3, 6) = Worksheets(2).Cells(i2_t, 1)
Worksheets(3).Cells(i3, 7) = Worksheets(2).Cells(i2_t, 2)
Worksheets(3).Cells(i3, 8) = Worksheets(2).Cells(i2_t, 3)
Worksheets(3).Cells(i3, 9) = Worksheets(2).Cells(i2_t, 4)
Worksheets(3).Cells(i3, 10) = Worksheets(2).Cells(i2_t, 5)
Worksheets(3).Cells(i3, 4).NumberFormatLocal = "yyyy/m/d"
Worksheets(3).Cells(i3, 9).NumberFormatLocal = "yyyy/m/d"
End If
End If
Next
Next
補足です。
・変数について
1).Const cnsDIR = "\*.*"
上記コメントにある通り、[strFilename = Dir(strPath1 & cnsDIR, vbNormal)]でフォルダからファイル名を取得するときの対象を指定ます。
指定の'*'は、ワイルドカードの1つで、ファイル名も拡張子も全ての文字列を対象にします。
[Const cnsDIR = "\ファイル1*.*]と指定して実行すると、先頭からの文字が'ファイル1'のファイルしか対象にしません。
2).Dim strPath1 As String
[As String]は、文字型変数を指定します。
・初期設定シート３の[j_t = (j - 1) * 5]について
シート３の列、1～5,6～10をグループとして見出しの最後に'1','2'を付加するためのベースとなる値を計算します。
そして、そのときの[Worksheets(3).Cells(1, j_t + 1) = "番号" & j]は、
j=1の時のj_tは、(1 -1) × 5 = 0 → 0 + 1 = 1 → "番号1"が1番目の列に入ります
j=2の時のj_tは、(2 -1) × 5 = 5 → 5 + 1 = 6 → "番号2"が6番目の列に入ります
となります。
ちなみに文字列は'&'で連結できます。
・初期設定シート３を改善
[初期設定シート３]は、[初期設定シート２]と同じ内容をセットしています。
当記事を公開するとき更に効率的にできることは認識していたのですが、反って分かりにくくなってしまうと考えて止めました。
ですが「追記する形であれば比較しながら理解されやすいかも」と考えて改善した内容を紹介します。
変数[iy_t2]を、既に"Dim文"で定義している[iy_t]の後に追加しておきます。
そしてコメントの「初期設定 シート３」部分の処理を以下のように修正します。
'初期設定 シート３
Worksheets(3).Cells.Clear
For iy = 1 To 2
iy_t = (iy - 1) * 5
For iy_t2 = 1 To 5
Worksheets(3).Cells(1, iy_t + iy_t2) = Worksheets(2).Cells(1, iy_t2) & iy
Next
Next
更に記事では[5]になっている部分を変数化し、列数の増減に伴い変数にセットする値を変えるだけで簡単に修正できます。
５つある[番号,フォルダ,ファイル名,更新日,サイズ]に２項目追加した７項目になる場合には、変数[iy_retu]を定義して
'<注意>列数が増減した場合には変更すること
iy_retu = 7
'初期設定 シート３
Worksheets(3).Cells.Clear
For iy = 1 To 2
iy_t = (iy - 1) * iy_retu
For iy_t2 = 1 To iy_retu
Worksheets(3).Cells(1, iy_t + iy_t2) = Worksheets(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
と出力されます。
④～⑥のデータは不要です。
そのためシート３に出力するときに、すでに[１]のフォルダ名・ファイル名が[２]にあれば出力しないようにして、ない場合に出力するようにしました。
もし、すべて出力したい場合には「i3_find = 0」から「If i3_find = 0 Then」と連動する「End If」を１行削除します。
フォルダ配下全てからリストアップ
機能追加したプログラムです。
上記で紹介したプログラムは、シート１で指定したフォルダ直下のファイル名が比較対象でした。
ここで紹介するプログラムは、
です。
シート１で指定したフォルダ配下のすべてのファイルが対象になるため、１つしか指定しなかった場合にはそのフォルダ内で同じファイル名が存在する場合、指定フォルダ直下にfile1.txt、指定フォルダ内のサブフォルダ内にfile1.txtが存在する場合には「重複データ」としてピックアップされます。
その更に下のサブフォルダに同じファイル名があれば同様に「重複データ」としてピックアップされます。
プログラムをVBA上に貼り付けるときは、[Sub (test) ～ End Sub]まで全てを削除してから貼り付けます。
作成するプログラム名を例えば'check1'としても、コーディングされている'test'になります。
変更したい場合は、貼り付けた後に変えるか、事前にメモ帳(notepad)などで変えてから貼り付けます。
'変数定義
'フォルダ内すべてを対象にするための定義
Const cnsDIR = "\*.*"
Dim strPath1 As String
Dim strFilename, strFilenameFull As String
Dim i1, i2, i2_t, i3, i3_t, i3_find, j, j_t As Long
Dim last_row1, last_row2 As Long
'メイン処理
Sub test()
'初期設定 シート２
Worksheets(2).Cells.Clear
Worksheets(2).Cells(1, 1) = "番号"
Worksheets(2).Cells(1, 2) = "フォルダ"
Worksheets(2).Cells(1, 3) = "ファイル名"
Worksheets(2).Cells(1, 4) = "更新日"
Worksheets(2).Cells(1, 5) = "サイズ"
'初期設定 シート３
Worksheets(3).Cells.Clear
For j = 1 To 2
j_t = (j - 1) * 5
Worksheets(3).Cells(1, j_t + 1) = "番号" & j
Worksheets(3).Cells(1, j_t + 2) = "フォルダ" & j
Worksheets(3).Cells(1, j_t + 3) = "ファイル名" & j
Worksheets(3).Cells(1, j_t + 4) = "更新日" & j
Worksheets(3).Cells(1, j_t + 5) = "サイズ" & j
Next
'シート１に指定した対象フォルダからシート２にファイル情報を取得
last_row1 = Worksheets(1).Range("B1").End(xlDown).Row
i2 = 1
For i1 = 2 To last_row1
strPath1 = Worksheets(1).Cells(i1, 2)
' 対象ディレクトリが存在するか、間違えていないかをチェック
If Dir(strPath1, vbDirectory) = "" Then
MsgBox "指定のドキュメントフォルダは存在しません。", vbExclamation
MsgBox (strPath1)
Exit Sub
End If
'
Call Dirlist(strPath1)
Next
' シート２の最終行を退避
last_row2 = i2
'シート２をチェックしシート３に出力する処理
i3 = 1
For i2 = 2 To last_row2 - 1
For i2_t = i2 + 1 To last_row2
If Worksheets(2).Cells(i2, 3) = Worksheets(2).Cells(i2_t, 3) Then
' 同じフォルダ名・ファイル名がまだ格納されていないかをチェックする
i3_find = 0
For i3_t = 2 To i3
If Worksheets(2).Cells(i2_t, 2) = Worksheets(3).Cells(i3_t, 7) And _
Worksheets(2).Cells(i2_t, 3) = Worksheets(3).Cells(i3_t, 8) Then
i3_find = i3_t
i3_t = i3
End If
Next
' 同じフォルダ名・ファイル名がまだ格納されていない場合には、シート３に出力する
If i3_find = 0 Then
i3 = i3 + 1
Worksheets(3).Cells(i3, 1) = Worksheets(2).Cells(i2, 1)
Worksheets(3).Cells(i3, 2) = Worksheets(2).Cells(i2, 2)
Worksheets(3).Cells(i3, 3) = Worksheets(2).Cells(i2, 3)
Worksheets(3).Cells(i3, 4) = Worksheets(2).Cells(i2, 4)
Worksheets(3).Cells(i3, 5) = Worksheets(2).Cells(i2, 5)
Worksheets(3).Cells(i3, 6) = Worksheets(2).Cells(i2_t, 1)
Worksheets(3).Cells(i3, 7) = Worksheets(2).Cells(i2_t, 2)
Worksheets(3).Cells(i3, 8) = Worksheets(2).Cells(i2_t, 3)
Worksheets(3).Cells(i3, 9) = Worksheets(2).Cells(i2_t, 4)
Worksheets(3).Cells(i3, 10) = Worksheets(2).Cells(i2_t, 5)
Worksheets(3).Cells(i3, 4).NumberFormatLocal = "yyyy/m/d"
Worksheets(3).Cells(i3, 9).NumberFormatLocal = "yyyy/m/d"
End If
End If
Next
Next
MsgBox "処理終了"
End Sub
'Dirlist
Sub Dirlist(ByVal Path As String)
Dim fl As Object
Dim fso As Object
Dim p_file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
strFilename = Dir(Path & "\*.*")
Do While strFilename <> ""
i2 = i2 + 1
Worksheets(2).Cells(i2, 1).Value = i2 - 1
Worksheets(2).Cells(i2, 2).Value = Path
Worksheets(2).Cells(i2, 3).Value = strFilename
strFilenameFull = Path & "\" & strFilename
Worksheets(2).Cells(i2, 4) = FileDateTime(strFilenameFull)
Worksheets(2).Cells(i2, 5) = FileLen(strFilenameFull)
strFilename = Dir()
Loop
For Each fl In CreateObject("Scripting.FileSystemObject").GetFolder(Path).SubFolders
Call Dirlist(fl.Path)
Next fl
End Sub
詳細については説明致しません。
最後に
少し長いプログラムになりました。
ですが、この記事を含め紹介しているプログラムはすぐに使えるものです。
基本的な命令だけで、難しい命令は極力使わないように心がけています。
今回の記事で使ったデータは、Windowsのフォルダから持ってくるファイル情報でした。
UNIXなど別OSのフォルダ情報合や手元にある資料データなどの場合には、最初の「Windowsのフォルダから持ってくる」処理は不要であったり、プログラムの内容を変更する必要があります。
手元にあるデータで重複チェックを行いたい場合には、シート２にデータを出力する「Windowsのフォルダから持ってくる」処理を削除します。
そして、見出しやチェックする項目の位置を変更する必要があります。
「Windowsのフォルダから持ってくるファイル情報をチェックする」だけでしか使えないわけではありません。
現場で発生する問題を解決するために、例えば「フォルダの一覧を作成する」といった部分的に使えるものもあり、応用していって頂ければと思います。
プログラムの内容を変更する場合に正常に動作しなくなったら、再度当記事からコピーして、かつ、処理の内容を理解してご対応頂ければ。
コメント