Sub test()
Dim a&, b&, arr1(), arr2(), dd1&(), dd2&(), tt!, kf!, t!
b = 1000000: kf = 0.5
ReDim arr1(1 To b, 1 To 2): ReDim arr2(1 To b, 1 To 2)
ReDim dd1(1 To b): ReDim dd2(1 To b): Randomize
tt = Timer
For a = 1 To b
  arr1(a, 1) = "ddd_" & Int(Rnd * b)
  arr2(a, 1) = "ddd_" & Int(Rnd * b)
Next
tt = Timer - tt: t = t + tt
Debug.Print "Array = " & Format(b, "#,###,###") & " Generation time " & Format(tt, "0.000")
tt = Timer
For a = 1 To b
  dd1(a) = CLng(Mid(arr1(a, 1), InStr(arr1(a, 1), "_") + 1))
  dd2(a) = CLng(Mid(arr2(a, 1), InStr(arr2(a, 1), "_") + 1))
Next
tt = Timer - tt: t = t + tt
Debug.Print "Array = " & Format(b, "#,###,###") & " MID/Instr separation time " & Format(tt, "0.000")
tt = Timer
NumSortIdx dd1(), kf: NumSortIdx dd2(), kf
tt = Timer - tt: t = t + tt
Debug.Print "Array = " & Format(b, "#,###,###") & " Sorting time " & Format(tt, "0.000")
tt = Timer
EqualArr arr1(), arr2(), dd1(), dd2()
tt = Timer - tt: t = t + tt
Debug.Print "Array = " & Format(b, "#,###,###") & " Checking arrays time " & Format(tt, "0.000")
Debug.Print "Array = " & Format(b, "#,###,###") & " Total time " & Format(t, "0.000")Erase arr1: Erase arr2: Erase dd1: Erase dd2
End Sub 

Sub EqualArr(arr1(), arr2(), aa1&(), aa2&())
Dim a&, b&
a = LBound(arr1): b = LBound(arr2)
Do
  Do While arr1(aa1(a), 1) < arr2(aa2(b), 1)
    a = a + 1
    If a > UBound(arr1) Then Exit Do
  Loop
  If a > UBound(arr1) Then Exit Do
  Do While arr1(aa1(a), 1) > arr2(aa2(b), 1)
    b = b + 1
    If b > UBound(arr2) Then Exit Do
  Loop
  If b > UBound(arr2) Then Exit Do
  Do While arr1(aa1(a), 1) = arr2(aa2(b), 1)
    arr1(aa1(a), 2) = arr1(aa1(a), 2) + 1: a = a + 1
    arr2(aa2(b), 2) = arr2(aa2(b), 2) + 1: b = b + 1
    If a > UBound(arr1) Or b > UBound(arr2) Then Exit Do
  Loop
  If a > UBound(arr1) Or b > UBound(arr2) Then Exit Do
Loop
End Sub

Sub NumSortIdx(InArr&(), Optional ByVal kf! = 0.5)
Dim arr(), aa&(), bb&(), a&, b&, c&, x&, z&
Dim iMin#, iMax#
iMax = UBound(InArr) / 5: iMin = iMax
ReDim Preserve aa(LBound(InArr) To UBound(InArr))
For a = LBound(aa) To UBound(aa)
  Select Case InArr(a)
    Case Is > iMax: iMax = InArr(a)
    Case Is < iMin: iMin = InArr(a)
  End Select
Next
ReDim arr(1 To (iMax - iMin) * kf)
z = (iMax - iMin) / ((iMax - iMin) * kf)
For a = LBound(aa) To UBound(aa)
  If InArr(a) > 0 Then
    x = InArr(a) / z
    If x < 1 Then x = 1
    If x > UBound(arr) Then x = UBound(arr)
  Else: x = 1
  End If
  arr(x) = arr(x) + 1
Next
For a = LBound(aa) To UBound(aa)
  If InArr(a) > 0 Then
    x = InArr(a) / z
    If x < 1 Then x = 1
    If x > UBound(arr) Then x = UBound(arr)
  Else: x = 1
  End If
  If Not IsArray(arr(x)) Then
    ReDim bb(1 To arr(x) + 1): bb(1) = 1
    bb(2) = a: arr(x) = bb
  Else
    bb = arr(x): bb(1) = bb(1) + 1
    bb(bb(1) + 1) = a: arr(x) = bb
  End If
Next
z = LBound(InArr)
For a = 1 To UBound(arr)
  If IsArray(arr(a)) Then
    bb = arr(a): x = z
    If bb(1) = 1 Then
      aa(z) = bb(2)
    Else
      aa(z) = bb(2)
      For b = 3 To bb(1) + 1
        z = z + 1: c = z
        Do While InArr(aa(c - 1)) > InArr(bb(b))
          aa(c) = aa(c - 1): c = c - 1
          If c = x Then Exit Do
        Loop
        aa(c) = bb(b)
      Next
    End If
    z = z + 1
  End If
Next
InArr = aa: Erase aa: Erase bb
End Sub

Array = 100 000 Generation time 0,078
Array = 100 000 MID/Instr separation time 0,078
Array = 100 000 Sorting time 0,250
Array = 100 000 Checking arrays time 0,047
Array = 100 000 Total time 0,453
Array = 500 000 Generation time 0,406
Array = 500 000 MID/Instr separation time 0,357
Array = 500 000 Sorting time 1,545
Array = 500 000 Checking arrays time 0,141
Array = 500 000 Total time 2,449
Array = 1 000 000 Generation time 0,811
Array = 1 000 000 MID/Instr separation time 0,701
Array = 1 000 000 Sorting time 3,324
Array = 1 000 000 Checking arrays time 0,482
Array = 1 000 000 Total time 5,318