EXCEL VBA

Excel-VBA 実例 重複チェックして重複データを抽出する

EXCEL VBA

こんにちは! 健史です。

「Excelシートのある列項目が重複しているデータを探したい!」ということありませんか。

Excelの「COUNTIF 関数」を使えばできますが、処理データを現場にありそうなフォルダ情報から作成し、重複チェックするプログラムを作成してみました。

この記事のプログラムは仕様確認せずにプログラムをご覧頂いても分かりにくく、ご面倒でも「プログラムの作成と実行」を順次読み進めて頂く方が「プログラムを理解する時間」を短縮できると思います、プログラムの内容に至るには時間にして1~2、3分かと思います。

スポンサーリンク

プログラムの作成と実行

今回のサンプルプログラムは

シート内のデータを重複チェックし、重複データを別シートに出力する

です。

複数のフォルダに同じ名前のファイルがあるかをチェックし、重複してあるものを抽出するプログラムです。

プログラムの概要は以下の通りです。
・シート1にチェック対象となるフォルダを指定する
・シート1のフォルダから、フォルダ名、ファイル名、更新日、サイズをシート2に出力する
・シート2のファイル名で重複しているものがないかチェックし、重複している場合にシート3に出力する


最後の「重複チェック」をExcelで対応する場合は、
・列を追加し、すべての行に'1'(カウント)を入力する
・ピボットテーブルを使い、上記で追加した[カウント]を集計する
・集計した結果「2以上」のファイル名を抽出する
・もとのシートを[ファイル名]でソートしておいて、上記で抽出したファイルを検索する
といった対応でしょうか。

そんな時に対応するプログラムです。

実行までの手順

1.Excelを起動

2.データ入力
Excel2007以降は、Sheet1のみであるためシートを2つ追加し、全部で3つ作成しておきます。

1).シート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   'シート2,シート3を追加し忘れた時の対応
    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
'初期設定 シート2
    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) = "サイズ"
'初期設定 シート3
    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
'シート1に指定した対象フォルダからシート2にファイル情報を取得
    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
' シート2の最終行を退避
    ix2_max = ix2
'シート2をチェックしシート3に出力する処理
    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
' 同じフォルダ名・ファイル名がまだ格納されていない場合には、シート3に出力する
              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キーを離すことで切り替わります。

シート2には、フォルダ・ファイル情報が出力されています。

そして、シート3には、同じファイル名の内容が出力されています。

プログラムの詳細説明

・初期設定シート3の[iy1_t = (iy1 - 1) * 5]について
シート3の列、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番目の列に入ります

となります。

ちなみに文字列は'&'で連結できます。

・初期設定シート3を改善
[初期設定シート3]は、[初期設定シート2]と同じ内容をセットしています。

当記事を公開するとき更に効率的にできることは認識していたのですが、反って分かりにくくなってしまうと考えて止めました。

ですが「追記する形であれば比較しながら理解されやすいかも」と考えて改善した内容を紹介します。

変数[iy_t2]をDim文で追加しておきます。

そしてコメントの「初期設定 シート3」部分の処理を以下のように修正します。

'初期設定 シート3
    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]になっている部分を変数化し、列数の増減に伴い変数にセットする値を変えるだけで簡単に修正できます。

5つある[番号,フォルダ,ファイル名,更新日,サイズ]に2項目追加した7項目になる場合には、変数[iy_retu]を定義して

'<注意>列数が増減した場合には変更すること
iy_retu = 7
'初期設定 シート3
    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

と修正します。

あまり変数化しすぎると、プログラムを追跡するのがたいへんになる場合もありますから良し悪しあります。

この例では"項目"を増減する頻度(後でプログラムを修正する頻度)が高いようであれば、後からみてもわかるコメントを残した上で変数化し、1度きりその場限りなど低いのであれば変数化しないといった対応が良いと思います。

・Do While strFilename <> "" について
「[Loop]までの処理を[strFilename <> ""]:strFilenameがNullでない間処理する」という意味です。

[strFilename = Dir(strPath1 & cnsDIR, vbNormal)]で1件目のファイル名を取得し、1件もなければnullなので処理は行いません。

1件でもあれば処理を行い、[strFilename = Dir()]で次のファイル名を取得し、なければ条件を満たすので処理は抜けます。

・同じフォルダ名・ファイル名がまだ格納されていないかをチェックする
今回「同じフォルダ名・ファイル名がまだ格納されていないかをチェックする」が無い処理の場合、01.フォルダAから04.フォルダDにも全てに同じファイル名が存在すると、
      [1]           [2]     
①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
と出力されます。

④~⑥のデータは不要です。

そのためシート3に出力するときに、すでに[1]のフォルダ名・ファイル名が[2]にあれば出力しないようにして、ない場合に出力するようにしました。

もし、すべて出力したい場合には「ix3_find = 0」から「If ix3_find = 0 Then」と連動する「End If」を1行削除します。

フォルダ配下全てからリストアップ

機能追加したプログラムです。

上記で紹介したプログラムは、シート1で指定したフォルダ直下のファイル名が比較対象でした。

ここで紹介するプログラムは、

シート1で指定したフォルダ内のサブフォルダ、さらにそのサブフォルダ・・・からすべてのファイル名をシート2にリストアップして処理する

です。

シート1で指定したフォルダ配下のすべてのファイルが対象になるため、1つしか指定しなかった場合にはそのフォルダ内で同じファイル名が存在する場合、指定フォルダ直下に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   'シート2,シート3を追加し忘れた時の対応
    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
'初期設定 シート2
    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) = "サイズ"
'初期設定 シート3
    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
'シート1に指定した対象フォルダからシート2にファイル情報を取得
    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
' シート2の最終行を退避
    ix2_max = ix2
'シート2をチェックしシート3に出力する処理
    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
' 同じフォルダ名・ファイル名がまだ格納されていない場合には、シート3に出力する
              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のフォルダから持ってくる」処理は不要であったり、プログラムの内容を変更する必要があります。

手元にあるデータで重複チェックを行いたい場合には、シート2にデータを出力する「Windowsのフォルダから持ってくる」処理を削除します。

そして、見出しやチェックする項目の位置を変更する必要があります。

「Windowsのフォルダから持ってくるファイル情報をチェックする」だけでしか使えないわけではありません。

現場で発生する問題を解決するために、例えば「フォルダの一覧を作成する」といった部分的に使えるものもあり、応用していって頂ければと思います。

プログラムの内容を変更する場合に正常に動作しなくなったら、再度当記事からコピーして、かつ、処理の内容を理解してご対応頂ければ。

尚この記事は、Excel-VBAを起動して貼り付ければ動作することを目指しています。

Excel-VBAの構造、起動方法、実行方法などを理解されていない方は、以下の記事を参照しながら一度やってみてから対応されることをお勧めします。

Excel-VBA 実例 この通りやれば動く、とにかく触ってみよう
こんにちは! 健史です。 パソコンをお使いの方の多くは、表計算ソフトExcelを利用されていると思います。 この記事は、Exceは知っているけれど ・Excel-VBAって何? ・Excel-VBAは取っ付きにくい! ・E...

実行中に発生したエラーの対処法は、上記記事の2.エラーが発生したときの対処法に記載しています。(この段落のリンクから直接遷移します)

EXCEL VBA
スポンサーリンク
- 面白かったらシェアお願いします! -
健史をフォローする
自分で改善

コメント