Function NumMap(txt$, arr&(), c&, d&) As Boolean
Dim a&, b&, sb$
c = 0: d = 1
If Len(txt) = 0 Then NumMap = False: Exit Function
ReDim arr(1 To Len(txt) * 2): a = 1: sb = Mid$(txt, a, 1)
Do
  Do While Not sb Like "#"
    a = a + 1
    If a > Len(txt) Then Exit Do
    sb = Mid$(txt, a, 1)
  Loop
  If a > Len(txt) Then Exit Do
  c = c + 1: arr(c * 2 - 1) = a
  Do While sb Like "#"
    a = a + 1
    If a > Len(txt) Then Exit Do
    sb = Mid$(txt, a, 1)
  Loop
  If a - arr(c * 2 - 1) > 0 Then
    b = a - arr(c * 2 - 1): arr(c * 2) = b
    If b > arr(d + 1) Then d = c * 2 - 1
  End If
Loop While a < Len(txt)
If c > 0 Then
  ReDim Preserve arr(1 To c * 2): NumMap = True
Else: ReDim arr(1 To 2)
End If
End Function
'------------------
Function NumCount(txt$, arr&(), c&, d&) As Boolean
Dim sb$, a&, ff As Boolean, b&
ff = False: ReDim arr(1 To Len(txt) * 2): c = 0: b = 0: d = 1
If Len(txt) = 0 Then NumCount = False: Exit Function
For a = 1 To Len(txt)
  sb = Mid$(txt, a, 1)
  If sb Like "#" Then
    If Not ff Then c = c + 1: arr(c * 2 - 1) = a: ff = True
  ElseIf ff Then
    b = a - arr(c * 2 - 1): arr(c * 2) = b: ff = False
    If b > arr(d + 1) Then d = c * 2 - 1
  End If
Next
If ff Then
  b = a - arr(c * 2 - 1) + 1: arr(c * 2) = b
  If b > arr(d + 1) Then d = c * 2 - 1
  ReDim Preserve arr(1 To c * 2)
  NumCount = True: Exit Function
End If
If c > 0 Then
  ReDim Preserve arr(1 To c * 2)
  NumCount = True
End If
End Function

Sub Test()
Dim dt$, arr&(), c&, d&, tt#, a&
dt = "afgdhrt456464bnhfy6785ghyrtdbssss123ghy56748393dfgd"
For c = 1 To 8: dt = dt & dt: Next
c = Len(dt)
Debug.Print "F.name"; Tab, "Str.len"; Tab; "For-Next"; Tab; "Elapsed"; Tab; "Maped"
tt = Timer
For a = 1 To 100000
  NumCount dt, arr(), c, d
Next
Debug.Print "NumCount"; Tab; Len(dt); Tab; 100000; Tab; Round(Timer - tt, 3); Tab; UBound(arr) / 2
tt = Timer
For a = 1 To 100000
  NumMap dt, arr(), c, d
Next
Debug.Print "NumMap"; Tab; Len(dt); Tab; 100000; Tab; Round(Timer - tt, 3); Tab; UBound(arr) / 2
End Sub

Функция        длина стр.    Повторов      Время
NumCount       13056         100000        187,547 
NumMap         13056         100000        212,195
'----------
NumCount       13056         100000        182,836
NumMap         13056         100000        206,211

Function NumExArrT(txt$, arr$(), d&) As Boolean
Dim a&, b&, nn$, ll&, c&
c = 0: d = 1: nn = "#": ll = Len(txt)
If ll = 0 Then NumExArrT = False: Exit Function
ReDim arr(1 To ll / 2 + 1): a = 1
Do
  Do Until Mid$(txt, a, 1) Like "#"
    a = a + 1
    If a > ll Then Exit Do
  Loop
  If a > ll Then Exit Do
  c = c + 1: nn = "##": b = 2
  Do While Mid$(txt, a, b) Like nn
    nn = nn & "#": b = b + 1
  Loop
  arr(c) = Mid$(txt, a, b - 1): a = a + b - 1
  If b > Len(arr(d)) Then d = c
Loop While a < ll
If c > 0 Then
  ReDim Preserve arr(1 To c): NumExArrT = True
Else: ReDim arr(1 To 1)
End If
End Function