Extraire un groupe de caractères vers une seule cellule, selon condition

Function RegrouperCar(c As String, Rang As Integer) As String
Dim s As Variant, i As Long, res As String, Nb As Integer
c = Replace(Replace(c, "[", "/"), "]", "/")
s = Split(c, "/")
For i = 1 To Len(s(0))
  res = res & Mid(s(0), i, 1) & " ": Nb = Nb + 1
Next i
s(0) = Left(res, Len(res) - 1): res = vbNullString
For i = 1 To Len(s(2))
  res = res & Mid(s(2), i, 1) & " ": Nb = Nb + 1
Next i
s(2) = Left(res, Len(res) - 1)
s = Split(Join(s))
If Rang - 1 <= Nb Then RegrouperCar = s(Rang - 1)
End Function

=RegrouperCar($A3;COLONNES($A:A))

=REPT(STXT($A21;N;1);N<X)&REPT(Mot;N=X)&REPT(STXT($A21;N+NBCAR(Mot)+1;1);N>X)

Function RegrouperCar(c As String, Rang As Integer) As String
Dim s As Variant, i As Integer, j As Integer, res As String, Nb As Integer
If c = vbNullString Then Exit Function
c = Replace(Replace(c, "[", "/|"), "]", "|/")
s = Split(c, "/")
For i = LBound(s) To UBound(s)
  If s(i) Like "|*|" Then
    s(i) = Replace(s(i), "|", ""): res = res & s(i) & " ": Nb = Nb + 1
  Else
    For j = 1 To Len(s(i))
      res = res & Mid(s(i), j, 1) & " ": Nb = Nb + 1
    Next j
  End If
Next i
res = Left(res, Len(res) - 1)
s = Split(res)
If Rang - 1 < Nb Then RegrouperCar = s(Rang - 1)
End Function

Function Crochets(t$, ordre%)
Dim i%, x$, grp As Boolean, n%
For i = 1 To Len(t)
  x = Mid(t, i, 1)
  If Not grp And x <> "[" Then
     Crochets = x
     n = n + 1
  ElseIf x <> "]" Then
    grp = True
    Crochets = Crochets & x
  Else
    grp = False
    n = n + 1
    Crochets = Mid(Crochets, 3 + (Left(Crochets, 1) = "["))
  End If
  If n = ordre Then Exit Function
Next
Crochets = ""
End Function

Function RegrouperCar(c As String, Rang As Integer) As String
Dim Reg As Object, Matches As Object
If c = vbNullString Then Exit Function
Set Reg = CreateObject("vbscript.regexp")
With Reg
  .Global = True
  .IgnoreCase = True
  .Pattern = "([A-Z]|[[A-Z]+])"
  If .test(c) = True Then Set Matches = .Execute(c)
End With
If Rang - 1 < Matches.Count Then RegrouperCar = Replace(Replace(Matches(Rang - 1), "[", ""), "]", "")
End Function

Sub Test()
Dim t
t = Timer
[A21:Q24].Copy [A25:Q20020]
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub