david porter cpl
New Member
- Joined
- Mar 11, 2022
- Messages
- 4
- Office Version
- 2016
- Platform
- Windows
I'm in need of advice please. The following code returns a 'type mismatch' error on the line 'If .test(A(i, 1)) Then'
The code was not written by myself, but serves to highlight characters within a string that doesn't follow a pattern. The code has worked for many months previously, but for some reason now consistently fails at this point.
Any help would be much appreciated. Many thanks
The code was not written by myself, but serves to highlight characters within a string that doesn't follow a pattern. The code has worked for many months previously, but for some reason now consistently fails at this point.
VBA Code:
Dim r As Range, A, e, w, i As Long, s
Dim mtch As Object, m As Object, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Set r = Range("h8", Range("h" & Rows.Count).End(xlUp))
A = r.Value: r.Font.ColorIndex = xlAutomatic
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
For i = 1 To UBound(A, 1)
.Pattern = "^[A-Z]+(?=\d+\b)"
If .test(A(i, 1)) Then
s = .Execute(A(i, 1))(0)
.Pattern = "\S+"
Set mtch = .Execute(A(i, 1))
.Pattern = s & "\d+"
For Each m In mtch
If Not .test(m) Then
r(i).Characters(m.firstindex + 1, m.Length).Font.Color = vbRed
Else
If Not dic.exists(m.Value) Then
ReDim w(1 To 2, 1 To 1)
Else
w = dic(m.Value)
ReDim Preserve w(1 To 2, 1 To UBound(w, 2) + 1)
End If
Set w(1, UBound(w, 2)) = r(i)
w(2, UBound(w, 2)) = Array(m.firstindex + 1, m.Length)
dic(m.Value) = w
End If
Next
End If
Next
End With
For Each e In dic
If UBound(dic(e), 2) > 1 Then
w = dic(e)
For i = 1 To UBound(w, 2) - 1
If w(1, i).Address = w(1, i + 1).Address Then
w(1, i + 1).Characters(w(2, i + 1)(0), w(2, i + 1)(1)).Font.Color = vbRed
Else
w(1, i).Characters(w(2, i)(0), w(2, i)(1)).Font.Color = vbRed
End If
Next
End If
NextAny help would be much appreciated. Many thanks
