Самео простое что приходит в голову - напротив строки ставится 1 если там есть такие слова и 0 если нет. То есть не нужно вычленять сами слова, достаточно указать, что в строке такие есть.
Sub slova()
Set diap = Intersect(ActiveSheet.UsedRange, Range("A:A"))
mas = diap.Value
ReDim mas2(1 To UBound(mas), 1 To 1)
For g = 1 To UBound(mas)
For i = 1 To Len(mas(g, 1)) - 1
t1 = Mid(mas(g, 1), i, 1)
t2 = Mid(mas(g, 1), i + 1, 1)
If t1 = UCase(t1) And t1 <> LCase(t1) And t2 = UCase(t2) And t2 <> LCase(t2) Then mas2(g, 1) = 1
Next
Next
diap.Offset(, 1).Value = mas2
End Sub
Sub mrshkei()
Dim x As Long, i As Long, lr As Long, arr, arr2
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A1:A" & lr)
ReDim arr2(1 To lr, 1 To 1)
For i = LBound(arr) To UBound(arr)
For x = 1 To Len(arr(i, 1))
x1 = UCase(Mid(arr(i, 1), x, 1))
x2 = Mid(arr(i, 1), x, 1)
If x2 Like "[A-ZА-ЯЁ]" Then
k = k + 1
End If
Next x
arr2(i, 1) = k
k = 0
Next i
Range("B1").Resize(UBound(arr2), 1) = arr2
End Sub
Function More2(cell$)
Dim mo As Object
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "[А-ЯЁ]{2,}"
If .test(cell) Then
Set mo = .Execute(cell)
More2 = mo.Count
Else
More2 = ""
End If
End With
End Function