文字制限VBA

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim cell As Range
    Dim countDict As Object

    ' イベント無限ループ防止
    Application.EnableEvents = False

    ' --- A列の重複チェック ---

    ' 背景色リセット（A列のみ）
    Me.Columns("A").Interior.ColorIndex = xlNone

    Set countDict = CreateObject("Scripting.Dictionary")
    Set rng = Me.Range("A1", Me.Cells(Me.Rows.Count, "A").End(xlUp))

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
            If countDict.exists(cell.Value) Then
                countDict(cell.Value) = countDict(cell.Value) + 1
            Else
                countDict.Add cell.Value, 1
            End If
        End If
    Next cell

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
            If countDict(cell.Value) > 1 Then
                cell.Interior.Color = RGB(255, 255, 0) ' 黄色
            End If
        End If
    Next cell

    ' --- B列の「あ」「い」以外チェック ---

    ' 対象がB列に含まれるならチェックする
    If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
        Dim bCell As Range
        For Each bCell In Intersect(Target, Me.Columns("B"))
            If Trim(bCell.Value) <> "" Then
                If bCell.Value <> "あ" And bCell.Value <> "い" Then
                    bCell.Interior.Color = RGB(255, 200, 200) ' ピンク
                Else
                    bCell.Interior.ColorIndex = xlNone ' OKな場合は色を消す
                End If
            Else
                bCell.Interior.ColorIndex = xlNone ' 空白も色を消す
            End If
        Next bCell
    End If

    Application.EnableEvents = True
End Sub