自分用です。
Excelに表を記載して表記ブレをチェックします。
やり方を簡潔にできなかったため、とてもわかりづらいです。
概要
・6行目以降に表を記載します
・5行目には表のカラムのタイトルを記載します
・4行目に「主キー」と「比較」の文字列を記入します。
・この「主キー」の列の値が同じ行同士を「比較」の列で等しいか検証しています。
・「主キー」、「比較」ともに複数OKです。
・比較列が等しくない場合、セルの背景が赤く塗られます。
・別途用意している「辞書」シートと「表記ブレリスト」シートに結果が記載されます。
「辞書」シート：主キー列の重複をマージした表
「表記ブレリスト」シート：比較列が等しくなかった行の一覧
表は色がついたままになるので、Module3に表をすべて削除するVBAと表の色を削除するVBAを付けました。
作成手順
・シートは3シート作成します。
「表」シート
「辞書」シート
「表記ブレリスト」シート
・「表」シートに下記の表を作成します。
4行目：操作可否→「主キー」と「比較」をセルに入力
5行目：表のタイトル(ヘッダー)
6行目以降：表の値(6行目から比較処理が始まります)
※１～３行目は何も処理しないのでマクロのボタンを自由に配置できます。
※他のシートには何も記載する必要はありません。
処理のたびに「辞書」シートと「表記ブレリスト」シートの値は消しているので値を削除する必要もありません。
図1 「表」シート
図2 表記ブレチェックした後の「辞書」シートと「表記ブレリスト」シート
VBAコード
Moduleは3つ作成します。
Module1
main処理
Sub 辞書比較ツール()
On Error GoTo エラー
'主キーとなる列、比較する列を格納する
Dim 主キー配列() As String, 比較配列() As String
主キー配列 = Split(単語検索("主キー"), ",")
比較配列 = Split(単語検索("比較"), ",")
'辞書を作成する
Dim 主キー辞書 As Object
Set 主キー辞書 = CreateObject("Scripting.Dictionary")
Dim 主キー文字列 As String
Dim 表記ゆれ主キーVal As String
表記ゆれ主キーVal = ""
Dim 参照表シート As Worksheet
Set 参照表シート = ThisWorkbook.Sheets("表")
With 参照表シート
For i = 6 To .Range("B20000").End(xlUp).Row
'主キー文字列は主キーの指定された行を「and」で連結した値を格納する
主キー文字列 = ""
For Each 主キー列 In 主キー配列
主キー文字列 = 主キー文字列 & .Cells(i, CInt(主キー列)) & "and"
Next 主キー列
If Not 主キー辞書.Exists(主キー文字列) Then
'辞書に存在しない場合、辞書に主キー文字列とセルの行数を新規追加する
主キー辞書.Add 主キー文字列, i
Else
'すでに辞書に登録されている場合
主キー辞書.Item(主キー文字列) = 主キー辞書.Item(主キー文字列) & "," & i
'一番目に格納した行と表記ブレする行の比較したい列を比較する
Dim 一番目取り出し用() As String
一番目取り出し用 = Split(主キー辞書.Item(主キー文字列), ",")
Dim 一番目 As Integer
一番目 = CInt(一番目取り出し用(0))
For Each 比較列 In 比較配列
If 0 <> StrComp(.Cells(一番目, CInt(比較列)), .Cells(i, CInt(比較列))) Then
'比較して同じ値ではなかった場合,
'背景を赤く塗る
.Cells(一番目, CInt(比較列)).Interior.Color = vbRed
.Cells(i, CInt(比較列)).Interior.Color = vbRed
'表記ゆれ主キーValに追加する
表記ゆれ主キーVal = 表記ゆれ主キーVal & 主キー文字列 & ","
End If
Next 比較列
End If
Next
Dim 表記ゆれ主キーリスト() As String
表記ゆれ主キーリスト() = Split(Left(表記ゆれ主キーVal, Len(表記ゆれ主キーVal) - 1), ",")
End With
'結果を出力
'主キーの一覧を出力
Dim 出力シート_主キー As Worksheet
Set 出力シート_主キー = ThisWorkbook.Sheets("辞書")
Dim 出力シート_主キーInsert行 As Integer
出力シート_主キーInsert行 = 6
出力シート_主キー.Cells.Clear
参照表シート.Rows("4:5").Copy Destination:=出力シート_主キー.Rows("4:5")
For Each キー In 主キー辞書
Dim 主キー行取得() As String
主キー行取得 = Split(主キー辞書.Item(キー), ",")
参照表シート.Rows(CInt(主キー行取得(0))).Copy Destination:=出力シート_主キー.Rows(出力シート_主キーInsert行)
出力シート_主キーInsert行 = 出力シート_主キーInsert行 + 1
Next キー
'表記ブレした列の一覧を出力
Dim 出力シート_表記ブレ As Worksheet
Set 出力シート_表記ブレ = ThisWorkbook.Sheets("表記ブレリスト")
Dim 出力シート_表記ブレInsert行 As Integer
出力シート_表記ブレInsert行 = 6
出力シート_表記ブレ.Cells.Clear
参照表シート.Rows("4:5").Copy Destination:=出力シート_表記ブレ.Rows("4:5")
For Each キー In 表記ゆれ主キーリスト
Dim 表記ブレ行取得() As String
表記ブレ行取得 = Split(主キー辞書.Item(キー), ",")
For Each 表記ブレ行 In 表記ブレ行取得
参照表シート.Rows(CInt(表記ブレ行)).Copy Destination:=出力シート_表記ブレ.Rows(出力シート_表記ブレInsert行)
出力シート_表記ブレInsert行 = 出力シート_表記ブレInsert行 + 1
Next 表記ブレ行
Next キー
Exit Sub
エラー:
MsgBox ("4列名に「主キー」と「比較」を必ず入力してください")
End Sub
Module1
main処理内で使うFunction
4行目の「主キー」と「比較」が記載されているセルの場所を探す
Function 単語検索(ByRef 検索文字 As String) As String
On Error GoTo エラー
Dim 結果 As String
結果 = ""
Dim 表シート As Worksheet
Set 表シート = ThisWorkbook.Sheets("表")
Dim 該当セル As Range, tempRng As Range
Dim 検索範囲 As Range
Set 検索範囲 = 表シート.Rows("4")
Set 該当セル = 検索範囲.Cells.Find(検索文字, LookAt:=xlWhole)
' 2個以上の場合に備え、検索結果を一時保存
Set tempRng = 該当セル
' 条件にあったセルが見つからなければNothingでループを抜ける
Do While Not 該当セル Is Nothing
結果 = 結果 & 該当セル.Column & ","
' FindNextで検索を継続
Set 該当セル = 検索範囲.Cells.FindNext(該当セル)
If 該当セル Is Nothing Then
Exit Do
End If
' これを忘れると無限ループになるので注意！
If 該当セル.Address = tempRng.Address Then
Exit Do
End If
Loop
単語検索 = Left(結果, Len(結果) - 1)
Exit Function
エラー:
単語検索 = "エラー発生"
End Function
Module3
おまけのデータクレンジング処理
Sub 表リセット()
ans = MsgBox("6行目以降を削除して表をリセットしますか", vbYesNo)
If ans = vbYes Then
ThisWorkbook.Sheets("表").Row("6:20000").Clear
End If
End Sub
Sub 表背景色リセット()
ans = MsgBox("背景色を削除しますか", vbYesNo)
If ans = vbYes Then
ThisWorkbook.Sheets("表").Rows("6:20000").Interior.ColorIndex = 0
End If
End Sub
おまけ
以前 複数のExcelファイルの表を集計するVBAも投稿しました。
一緒に使うと便利だと思います。