Excelマクロ・VBA 重複する値をピックアップする方法(ワイルドカードと不等号対応版)
条件付き書式で重複した値を探す場合、ワイルドカード*?~や不等号<>が
混ざっていると重複していなくてもCOUNTIF関数の挙動により
重複無しでも重複として反応してしまいます。
この記事では、その問題に対応した誰でも使用可能なブックとマクロのコードを紹介します。
目次
サンプルファイル
使用方法
「チェック対象」シートのA列に重複チェックしたい値を列挙し、B1のボタンを押下します。
「結果」シートが自動作成され2件以上、存在する値が列挙されます。
コードと説明
利用するだけであれば先述の手順だけでよいですが
カスタマイズしたい方やマクロの中身を知りたい方向けに
ソースコードの説明は下記のとおりです。
標準モジュール
Sub DuplicateCheck()
Dim checkTargetSheet, tempSheet, resultSheet As Worksheet
Const checkTargetSheetName = "チェック対象", resultSheetName = "結果", tempSheetName = "値別件数"
Set checkTargetSheet = Worksheets(checkTargetSheetName)
' tempシートと結果シートが存在するなら削除
Dim ws As Worksheet
Application.DisplayAlerts = False ' 削除メッセージを表示しない
For Each ws In Worksheets
If UCase(ws.Name) = resultSheetName Or UCase(ws.Name) = tempSheetName Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True ' 削除メッセージを表示するように戻す
' tempシートと結果シートを作成
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = tempSheetName
Set tempSheet = Worksheets(tempSheetName)
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = resultSheetName
Set resultSheet = Worksheets(resultSheetName)
checkTargetSheet.Range("A:A").Copy tempSheet.Range("A:A")
' ソート
tempSheet.Range("A:A").Sort Key1:=tempSheet.Range("A1"), order1:=xlAscending, Header:=xlNo
' 重複判定
Dim rowCount, sameCount As Integer
rowCount = 1
Dim currentValue As Variant ' 1行前の値
Do While Not tempSheet.Cells(rowCount, 1).Value = ""
If currentValue = tempSheet.Cells(rowCount, 1).Value Then
' 1行前と今回のセルが同値である
sameCount = sameCount + 1
Else
' 1行前と今回のセルが同値ではない
sameCount = 1
currentValue = tempSheet.Cells(rowCount, 1).Value
End If
tempSheet.Cells(rowCount, 2).Value = sameCount
rowCount = rowCount + 1
Loop
' 結果シートに重複値を書き出し
Dim tempSheetRowCount, resultSheetRowCount As Integer
tempSheetRowCount = 1
resultSheetRowCount = 1
Do While Not tempSheet.Cells(tempSheetRowCount, 2).Value = ""
If tempSheet.Cells(tempSheetRowCount, 2).Value = 2 Then
resultSheet.Cells(resultSheetRowCount, 1).Value = tempSheet.Cells(tempSheetRowCount, 1).Value
resultSheetRowCount = resultSheetRowCount + 1
End If
tempSheetRowCount = tempSheetRowCount + 1
Loop
End Sub