【Excel VBA】一つ上のセルと比較して先頭から同じ文字までを白色に変換

Excelの一覧表で、一つ上のセルと比較して先頭から同じ文字までを白色に変換するVBAサンプルです。

総務省の「統計表における機械判読可能なデータ作成に関する表記方法」において、次のように「同じ名称を空白で省略せず、入力すること」とされています。

「チェック項目1-6 項目名等を省略していないか」の抜粋 — 「統計表における機械判読可能なデータ作成に関する表記方法」（総務省）を加工して作成

しかし、上記の修正前の表記は、ヒトが見る上では文字列の違いをわかりやすく明示できる有効な方法の一つです。

そこで、機械判読可能なデータ作成との両立で、一つ上のセルと比較して先頭から同じ文字までを白色に変換するVBAサンプルです。

内容：

アウトプットイメージ
VBAサンプル
補足説明と注意点

アウトプットイメージ

次のように、ヒトが見る上では文字列は省略されています。

同じ名称の文字を白色に変換して見た目上の非表示にしています — 一つ上のセルと比較して先頭から同じ文字までを白色に変換

なお、上記はフォントの色を背景の白色に合わせた事例です。

動作を理解しやすくするため、フォントを薄い灰色にした事例は次のとおりです。

テキストデータはそのまま維持されていることが分かると思います。

VBAサンプル

事前に、フォントの色を変更したいセル範囲を選択しておきます（上記事例では、B3:D14を選択）。

選択された範囲の各セルについて、一つ上のセルと比較し、

・文字列が完全に一致する
・先頭から同じ文字が３文字以上つづく

のいずれかの場合、該当する文字列のフォントを白色に変更します。

Option Explicit
Dim 基準セル As Range
Dim 対象セル As Range

Sub 一つ上のセルと比較して先頭から同じ文字までを白色に変換()
    Dim 選択範囲 As Range
    Dim 最終行 As Long, 最終列 As Long, 行 As Long, 列 As Long

    Set 選択範囲 = Selection
    
    最終行 = Selection.Rows.Count
    最終列 = Selection.Columns.Count
    Application.DisplayAlerts = False
        
    For 列 = 1 To 最終列
        For 行 = 2 To 最終行 '結合の判定を2行目からするので'
            Set 基準セル = 選択範囲.Cells(行 - 1, 列)
            Set 対象セル = 選択範囲.Cells(行, 列)
            If 対象セル.Value <> "" Then Call 文字列単位で比較
        Next 行
    Next 列
    Application.DisplayAlerts = True
End Sub

Function 文字列単位で比較()

    Dim 基準文字列 As String
    Dim 対象文字列 As String
    Dim i As Integer
    Dim 一致する文字の連続数 As Long

    'セルから文字列を取得'
    基準文字列 = 基準セル.Value
    対象文字列 = 対象セル.Value

    '文字列全体で比較'
    If 基準文字列 = 対象文字列 Then
        対象セル.Font.Color = vbWhite '白色 vbWhite 薄い灰色 rgbLightGray'
        Exit Function
    Else
        対象セル.Font.ColorIndex = xlAutomatic '一旦リセット'
    End If
    
    '文字列単位で比較'
    一致する文字の連続数 = 0
    For i = 1 To Len(対象文字列)
        If Mid(基準文字列, i, 1) = Mid(対象文字列, i, 1) Then
           一致する文字の連続数 = 一致する文字の連続数 + 1
        Else
            Exit For
        End If
    Next i
    
    '先頭から一致する文字が3文字以上連続で文字を白色に変換'
    If 一致する文字の連続数 >= 3 Then
        対象セル.Characters(1, 一致する文字の連続数).Font.Color = vbWhite '白色 vbWhite 薄い灰色 rgbLightGray'
    End If
    
End Function