VBA Generic code

重複データ検索

選択セル範囲内の重複データを検索し、色を付けるマクロです。選択範囲が複数ある場合にも対応しており、最大20色まで色分けします。
セル範囲を選択し、マクロ「Overlap_Main」を実行します。
コードの貼り付け場所

サンプルコード

'///宣言セクション
Type AreasData
    Area As Variant
End Type

'/// Sub Overlap_Main() Dim c As Long, i As Long, j As Long, k As Long, ac As Long Dim rngTagt() As Range, typAreas() As AreasData If LCase(TypeName(Application.Selection)) <> "range" Then MsgBox "セル範囲を選択してください。", vbExclamation + vbOKOnly: Exit Sub End If ac = Selection.Areas.Count '選択セル範囲の数 For i = 1 To ac If Not Intersect(Selection.Areas(i), ActiveSheet.UsedRange) Is Nothing Then c = c + 1 ReDim Preserve rngTagt(1 To c), typAreas(1 To c) Set rngTagt(c) = Intersect(Selection.Areas(i), ActiveSheet.UsedRange) typAreas(c).Area = rngTagt(c) End If Next '///連想配列にデータを登録 Dim myDic As Object, bolAray As Boolean, bolOver As Boolean Dim strData As String, strAdrs(0 To 1) As String Set myDic = CreateObject("Scripting.Dictionary") For k = 1 To c With rngTagt(k) bolAray = IsArray(typAreas(k).Area) For i = 1 To .Rows.Count For j = 1 To .Columns.Count If bolAray Then strData = typAreas(k).Area(i, j) Else strData = typAreas(k).Area If 0 < Len(strData) Then If myDic.Exists(strData) Then '連想配列に重複がある(既に登録されている)場合 strAdrs(0) = myDic.Item(strData) '登録されているデータのセルアドレスを取得 myDic.Remove strData '登録データを削除 strAdrs(1) = .Cells(i, j).Address(False, False) '重複セルのアドレスを取得 myDic.Add strData, Join$(strAdrs, ",") '該当データと連結したセルアドレスを再登録 bolOver = True Else '連想配列に重複がない場合:該当データとセルアドレスを登録 myDic.Add strData, .Cells(i, j).Address(False, False) End If End If Next Next End With Next If Not bolOver Then MsgBox "重複するデータは有りません。", vbInformation + vbOKOnly: Exit Sub '///新たな連想配列に重複データのみを登録 Dim myDicO As Object, varKeys As Variant Set myDicO = CreateObject("Scripting.Dictionary") With myDicO varKeys = myDic.Keys For i = LBound(varKeys) To UBound(varKeys) '登録データのセルアドレスにカンマがあると重複データ If 0 < InStr(1, myDic.Item(varKeys(i)), ",") Then .Add varKeys(i), myDic.Item(varKeys(i)) Next '///重複データのセルアドレスを文字列型変数に格納 varKeys = .Keys ReDim strOver(UBound(varKeys)) As String For i = LBound(varKeys) To UBound(varKeys) strOver(i) = .Item(varKeys(i)) Next End With '///重複セルに色を付ける Dim varAdds As Variant For i = LBound(strOver) To UBound(strOver) If 200 < Len(strOver(i)) Then 'セルアドレスが200文字を超えた場合 varAdds = Split(strOver(i), ",") For j = LBound(varAdds) To UBound(varAdds) Range(varAdds(j)).Interior.ColorIndex = (i Mod 20) + 34 Next Else Range(strOver(i)).Interior.ColorIndex = (i Mod 20) + 34 End If Next End Sub

データが膨大な場合、時間がかかることがあります。
このコードを発展させた「重複するデータを検索」アドイン。データ担当必須のお薦めアドインです。

ページトップへ戻る
Copyright(C) 2009- 坂江保 All Rights Reserved.