'Option Base 1
Option Explicit
'Option Private Module
'==================================================================================================
Sub HighLightNumbers()
Dim dic As Object
Dim shPaint As Worksheet, rng As Range
Dim x, y, arr, t!, r&, c&, n&, AppC&

t = Timer
Set dic = CreateObject("Scripting.Dictionary")
arr = Worksheets("Номера").Range("A2:A248").Value2

For Each x In arr
    If Len(x) Then
        If InStr(x, vbLf) <> 0 Then
            For Each y In Split(x, vbLf)
                y = dic(y)
            Next y
        Else
            y = dic(x)
        End If
    End If
Next x

AppC = Application.Calculation: Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Set shPaint = Worksheets("карта номеров")
Set rng = shPaint.Range("A1:AN58")
arr = rng.Value2: rng.Font.Color = rgbSilver

For c = 1 To UBound(arr, 2)
    For r = 1 To UBound(arr, 1)
        If dic.exists(arr(r, c)) Then n = n + 1: rng(r, c).Font.Color = vbBlack
    Next r
Next c
Set dic = Nothing

Application.Calculation = AppC
Application.ScreenUpdating = True

If n = 0 Then MsgBox "No Value found!", vbExclamation, Format$(Timer - t, "0.0 sec"): Exit Sub
shPaint.Activate: MsgBox "Cells highlighted: " & Format$(n, "#,##0"), vbInformation, Format$(Timer - t, "0.0 sec")
End Sub
'==================================================================================================
'==================================================================================================