EXCEL VBA

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

EXCEL VBA

こんにちは! 健史(たけふみ)です。

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

最初は、真似ることです。

少しづつ何回も Excel-VBAの起動、実行に慣れて、プログラムにも目を通して理解を深め、自然に手が動くようになるまで頭の回路に焼き付けて頂ければと思います。

そして、活用できるレベルにいって頂ければと嬉しく思います。

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

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

プログラムの作成と実行

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

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

です。

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

プログラムの概要は以下の通りです。
・シート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 i1, i2, i2_t, i3, i3_t, i3_found, j, j_t As Long
    Dim last_row1, last_row2 As Long
'初期設定 シート2
    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) = "サイズ"
'初期設定 シート3
    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
'シート1に指定した対象フォルダからシート2にファイル情報を取得
    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
' シート2の最終行を退避
    last_row2 = i2
'シート2をチェックしシート3に出力する処理
    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_found = 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_found = i3_t
                     i3_t = i3
                  End If
              Next
' 同じフォルダ名・ファイル名がまだ格納されていない場合には、シート3に出力する
              If i3_found = 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キーを離すことで切り替わります。

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

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

フローチャート

[For~Next]の部分だけですが、以下の記事のフローチャートを参照下さい。

Excel-VBA 実例 シートの内容を比較して異なる部分を出力
こんにちは! 健史(たけふみ)です。 この記事は、Excel-VBAを起動して貼り付ければ動作することを目指しています。 最初は、真似ることです。 少しづつ何回も Excel-VBAの起動、実行に慣れて、プログラムにも目を...

変数名と処理回数が異なりますが、処理形式[For~Next]の中に[For~Next]は同じです。

今回は[For~Next]の中に[For~Next]さらにもう1回[For~Next]がある形です。

プログラムの詳細説明

上記フロー同様、プログラムの説明も以下の記事を参照下さい。

Excel-VBA 実例 シートの内容を比較して異なる部分を出力
こんにちは! 健史(たけふみ)です。 この記事は、Excel-VBAを起動して貼り付ければ動作することを目指しています。 最初は、真似ることです。 少しづつ何回も Excel-VBAの起動、実行に慣れて、プログラムにも目を...

上記記事にない部分を追記します。

'フォルダ内すべてを対象にするための定義
    Const cnsDIR = "\*.*"
        フォルダから抽出する対象ファイルを指定する
        *.*と指定することで「すべてのファイルのすべての拡張子」になります
'変数定義
    Dim strPath1 As String
    Dim strFilename, strFilenameFull As String
    Dim i1, i2, i2_t, i3, i3_t, i3_found, j, j_t As Long
    Dim last_row1, last_row2 As Long
'初期設定 シート2
    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) = "サイズ"
'初期設定 シート3
    Worksheets(3).Cells.Clear
    For j = 1 To 2
        j_t = (j - 1) * 5
            シート3の見出し項目が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
'シート1に指定した対象フォルダからシート2にファイル情報を取得
    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
                シート1で指定したフォルダが存在するかをチェックする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
' シート2の最終行を退避
    last_row2 = i2
'シート2をチェックしシート3に出力する処理
    i3 = 1
    For i2 = 2 To last_row2 - 1
            シート2の最終行の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_found = 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_found = i3_t
                     i3_t = i3
                  End If
              Next
' 同じフォルダ名・ファイル名がまだ格納されていない場合には、シート3に出力する
              If i3_found = 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]は、文字型変数を指定します。

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

となります。

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

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

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

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

変数[iy_t2]を、既に"Dim文"で定義している[iy_t]の後に追加しておきます。

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

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

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

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

と修正します。

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

この例では"項目"を増減する頻度(後でプログラムを修正する頻度)が高いようであれば、後からみてもわかるコメントを残した上で変数化し、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]にあれば出力しないようにして、ない場合に出力するようにしました。

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

最後に

少し長いプログラムになりました。

ですが、この記事を含め紹介しているプログラムはすぐに使えるものです。

基本的な命令だけで、難しい命令は極力使わないように心がけています。

今回の記事で使ったデータは、Windowsのフォルダから持ってくるファイル情報でした。

UNIXなど別OSのフォルダ情報合や手元にある資料データなどの場合には、最初の「Windowsのフォルダから持ってくる」処理は不要であったり、プログラムの内容を変更する必要があります。

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

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

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

現場で発生する問題を解決するために、応用していって頂ければと思います。

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

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

コメント