VBAテンプレート　表記ブレチェッカー

自分用です。
Excelに表を記載して表記ブレをチェックします。
やり方を簡潔にできなかったため、とてもわかりづらいです。

## 概要
・6行目以降に表を記載します
・5行目には表のカラムのタイトルを記載します
・4行目に「主キー」と「比較」の文字列を記入します。
・この「主キー」の列の値が同じ行同士を「比較」の列で等しいか検証しています。
・「主キー」、「比較」ともに複数OKです。
・比較列が等しくない場合、セルの背景が赤く塗られます。
・別途用意している「辞書」シートと「表記ブレリスト」シートに結果が記載されます。
「辞書」シート：主キー列の重複をマージした表
「表記ブレリスト」シート：比較列が等しくなかった行の一覧

表は色がついたままになるので、Module3に表をすべて削除するVBAと表の色を削除するVBAを付けました。


## 作成手順

・シートは3シート作成します。
  「表」シート
  「辞書」シート
  「表記ブレリスト」シート


・「表」シートに下記の表を作成します。

4行目：操作可否→「主キー」と「比較」をセルに入力
5行目：表のタイトル(ヘッダー)
6行目以降：表の値(6行目から比較処理が始まります)

※１～３行目は何も処理しないのでマクロのボタンを自由に配置できます。

※他のシートには何も記載する必要はありません。
処理のたびに「辞書」シートと「表記ブレリスト」シートの値は消しているので値を削除する必要もありません。


図1　「表」シート
![VBA_表記ブレチェッカー2022-06-30 215455.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2550991/5c594333-a9ec-a462-7993-e3160f17d288.png)

図2　表記ブレチェックした後の「辞書」シートと「表記ブレリスト」シート
![VBA_表記ブレチェッカー_結果2022-06-30 215455.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2550991/42f46bdb-cbd2-4fe8-cf01-00f4ff347828.png)



## 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も投稿しました。
一緒に使うと便利だと思います。

[VBAテンプレート　開始位置が異なる複数の表を集計する](https://qiita.com/cuvskr/items/0d4588670e3708f2944d)