Подсветка искомого цифрового значения

[Vitulus]

Уважаемые форумчане, помогите с кодом макроса.

Смысл заключается в том, чтобы в массиве данных найти ошибочные цифры, которые содержат погрешность:

1) наличие лишнего символа (например , ) " ' - ! $ ) ( - или буквы З вместо цифры "3", I вместо 1 и т.д. ) или
2) отсутствие максимум двух цифр, либо наличие лишней цифры (цифр) (т.е. для ошибкой будет считаться цифра с диапазоном 6 и 7 знаков, либо больше 8).

Если хотя бы одно из вышеуказанных условий встречается в массиве, строка с такой цифрой должна подсвечиваться желтым цветом.

Важно отделить такое искомое значение от почтового индекса (5 цифр) или дат, которые не должны подсвечиваться желтым.
P/s. Бывает так, что в датах также имеются ошибки (10 10 2013, 10 01 2014 и т.д., т.е. те же 8 цифр), но они должны игнорироваться для подстветки.

[maksim_serg]

Ну как то так:

Sub isError()

Dim Cif, str As String: Cif = "0123456789"
Dim Ls, k As Integer
Dim sl() As String

    For R = 1 To 55
        str = Cells(R, 1)
        str = Replace(str, ",", ";")
        sl = Split(str, ";")
        
        For Each s In sl
            s = Trim(s)
            Ls = Len(s)
            k = 0
            
            For b = 1 To Ls
                If InStr(1, Cif, Mid(s, b, 1)) > 0 Then k = k + 1
            Next
            
            If Ls = 0 Then Ls = 1
            
            If k / Ls = 1 And Ls = 8 Then
            
            ElseIf k / Ls > 0.6 Then
                If Ls > 5 Then
                    If Ls <> 8 Then
                        If Not IsDate(s) Then Call ColorCells(Cells(R, 1), s)
                    Else
                        For b = 1 To Len(s)
                            If InStr(1, Cif, Mid(s, b, 1)) < 1 Then
                                If Not IsDate(s) Then Call ColorCells(Cells(R, 1), s)
                            End If
                        Next
                    End If
                End If
            End If
            
        Next
    Next
End Sub

Sub ColorCells(Cell As Range, sSearchString)
    Dim iStart As Integer
        If Cell.Value Like "*" & sSearchString & "*" Then
            With Cell.Characters(Start:=InStr(Cell.Value, sSearchString), Length:=Len(sSearchString)).Font
                .Bold = True
                .Color = RGB(255, 0, 0)
            End With
        End If
End Sub

[Vitulus]

Всё отлично ! Спасибо, что откликнулись на просьбу. Единственный момент. Насколько я правильно понял, проверка в какой-то степени привязана к разделителю ;. Но к сожалению, не всегда перед цифрой стоит разделитель ; бывает так, что ставится : либо I и т.д.
Такая ошибка возникает из-за того, что текст распознается в Fine Reader, а оригинал документа не всегда хорошего качества.

Т.е. в примере как на скриншоте, цифра в первом массиве должна была бы подсветиться, но этого не произошло (из-за того, что разделитель не ;, а :).

[maksim_serg]

А Вы эту строку желтым цветом не выделили
Да и вообще трудно определить, где начинается 8-ми значное число. Файн ридер может и так распознать:
Крым45454545, Крым; 4545;5678, или так Крым 4545 7898
И дату от числа тоже трудно отделить.
Вот что тут написано, число или дата: 2211I2013? (пример из третьего пункта)
Я и не утверждал, что этот код найдет абсолютно все ошибки, это лишь пример

[Vitulus]

В том-то и дело, что все варианты невозможно выделить, но я уточнил специально есть ли привязка. Потому что когда я изменяю знак : на ; тогда подсветка появляется, а когда разделитель остается : так макрос вообще не реагирует. Из этого следует для меня, что знак ": должен быть изменен на ";.
Безусловно, что Вы сделали огромное дело ))). Вариации ошибок слишком разнообразны, поэтому создаю словарь, чтобы заменить наиболее встречающиеся проблемы с целью их пакетной замены на правильные данные. Кстати, по поводу даты, также очень хорошо, что подсветка происходит (безусловно, что единственной зацепкой будет только год, вероятность совпадения с 8-и значным
кодом очень мала). Ещё раз спасибо за помощь.

[maksim_serg]

Про разделитель: макрос заменят все запятые в строчке на точку с запятой. после чего разбивает строку на отдельные подпредложения, критерий новой подстроки - как раз точка с запятой.

[IgorGO]

см.вложение.
вот такая функция в условном форматировании проверяет содержимое строки

Function HasBadDgt(s As String)
  Dim t As String, RegEx As Object, m As Object, i As Long, c As Long
  Set RegEx = CreateObject("VBScript.RegExp"):  RegEx.Global = True
  RegEx.Pattern = "; .{8,9};"
  If RegEx.test(s) Then
    t = RegEx.Execute(s)(0)
    RegEx.Pattern = "\d":  Set m = RegEx.Execute(t)
    If m.Count = 8 and Len(t) = 11 Then Exit Function
    If m.Count > 5 Then HasBadDgt = True: Exit Function
  End If
  RegEx.Pattern = ".{5,6},"
  If RegEx.test(s) Then
    Set m = RegEx.Execute(s)
    RegEx.Pattern = "\d"
    For i = 0 To m.Count - 1
      If RegEx.Execute(m(i)).Count = 4 Then HasBadDgt = True: Exit Function
    Next
  End If
End Function