Sub test()
Dim txt$, dt$, tt#, a&, arrP
TextGen txt, 100000000, 100000000
TextGen dt, 3, 3
tt = Timer
a = TxtFindCount(txt, dt, arrP)
tt = Timer - tt
End Sub
'генератор символов
Function TextGen(tt$, ByVal ss&, ByVal ll&)
Dim aa As Byte, x&, t$, arr() As Byte, a As Byte, c&, bb() As Byte
ReDim arr(1 To 2, 1 To 2)
arr(1, 1) = 65: arr(1, 2) = 25: arr(2, 1) = 97: arr(2, 2) = 25
'arr(3, 1) = 192: arr(3, 2) = 31: arr(4, 1) = 224: arr(4, 2) = 31
t = ""
If ll - ss > 0 Then c = ss + (Rnd * (ll - ss)) Else c = ll
ReDim bb(1 To c)
For x = 1 To c
  a = Rnd * 2
  If a = 0 Then a = 1
  aa = arr(a, 1) + (Rnd * arr(a, 2))
  bb(x) = aa
Next
tt = StrConv(bb, 64)
End Function

Function TxtFindCount&(iStr$, ByVal txt$, Optional arrP)
Dim mtrx(), ll&, ch1 As Byte, ch2 As Byte, bb() As Byte, aa() As Byte, a&, b&, c&
Dim x&, arr&(), a1&, a2&, c1&, c2&, ff As Boolean
ll = Len(txt): aa = StrConv(txt, 128): bb = StrConv(iStr, 128)
ch1 = aa(0): ch2 = aa(UBound(aa)): x = 0: c = 2
ReDim mtrx(0 To 255)
For a = 0 To UBound(bb): mtrx(bb(a)) = mtrx(bb(a)) + 1: Next
For a = 0 To UBound(bb)
  If ch1 = bb(a) Or ch2 = bb(a) Then
    If Not IsArray(mtrx(bb(a))) Then
      ReDim arr(1 To mtrx(bb(a)) + 1): arr(1) = 2: arr(2) = a: mtrx(bb(a)) = arr()
      Else: mtrx(bb(a))(1) = mtrx(bb(a))(1) + 1: mtrx(bb(a))(mtrx(bb(a))(1)) = a
    End If
  End If
Next
If Not IsArray(mtrx(ch1)) Or Not IsArray(mtrx(ch2)) Then TxtFindCount = 0: Exit Function
If ll = 1 Then
  TxtFindCount = mtrx(ch1)(1) - 1: ReDim arrP(1 To mtrx(ch1)(1) - 1)
  For a = 2 To mtrx(ch1)(1): arrP(a - 1) = mtrx(ch1)(a) + 1: Next
  Exit Function
End If
ReDim arrP(1 To 1)
For a = 2 To mtrx(ch1)(1)
  For b = c To mtrx(ch2)(1)
    If mtrx(ch2)(b) > mtrx(ch1)(a) Then
      c = b
      If mtrx(ch1)(a) + ll - 1 <> mtrx(ch2)(b) Then Exit For
      a1 = mtrx(ch1)(a): a2 = mtrx(ch2)(b)
      c1 = 0: c2 = UBound(aa): ff = True: c = b + 1
      Do While a2 - a1 > 1
        c1 = c1 + 1: c2 = c2 - 1: a1 = a1 + 1: a2 = a2 - 1
        If aa(c1) = bb(a1) Then
          If aa(c2) <> bb(a2) Then ff = False: Exit Do
        ff = True
        Else: ff = False: Exit Do
        End If
      Loop
      If ff Then x = x + 1: ReDim Preserve arrP(1 To x): arrP(x) = mtrx(ch1)(a) + 1: Exit For
    End If
  Next
Next
If x = 0 Then Erase arrP
TxtFindCount = x
End Function