trouve

Sub xtest()
Dim tableau(100): Dim i As Byte: i = 1
For Each C In Range(Cells(1, 7), Cells(65536, 7).End(xlUp))
If C Like "1*" Or C Like "2*" Or C Like "3*" Then
tableau(i) = C: i = i + 1
End If
Next C
Application.ScreenUpdating = False: Worksheets("Feuil2").Activate: Cells(1, 1).Select
For Each x In tableau
ActiveCell = x: ActiveCell.Offset(1, 0).Activate
Next x
Application.ScreenUpdating = True
End Sub

Public Const monMax As Long = 5
Sub LesPremiers()
'Il te faut deux feuilles
  'Feuil1 avec tes données en colonne G
 'Feuil2 vierge
Dim tab1(1 To monMax) As Variant
Dim tab2(1 To monMax) As Variant
Dim tab3(1 To monMax) As Variant
Dim a, b, c As Integer
'on initialise le compteur
a = 0: b = 0: c = 0
'on recherche la dernière ligne de la colonne G
DerLi = Sheets("Feuil1").Columns(7).Find("*", , , , , xlPrevious).Row
For Each cell In Sheets("Feuil1").Range("G1:G" & DerLi)
'on recherche le premier caractère
Select Case Left(cell.Value, 1)
Case 1:  If a < monMax Then a = a + 1: tab1(a) = cell.Value
Case 2:  If b < monMax Then b = b + 1: tab2(b) = cell.Value
Case 3:  If c < monMax Then c = c + 1: tab3(c) = cell.Value
End Select
'on applique une condition pour sortir de la boucle
If a + b + c = 3 * monMax Then Exit For
Next cell
'on colle les donnée dans la Feuil2
With Sheets("Feuil2")
  .Range("A1:C" & monMax + 1).ClearContents
  .[A1] = "Commence par 1"
  .[B1] = "Commence par 2"
  .[C1] = "Commence par 3"
  For i = 1 To monMax
  .Cells(i + 1, 1).Value = tab1(i)
  .Cells(i + 1, 2).Value = tab2(i)
  .Cells(i + 1, 3).Value = tab3(i)
  Next
End With
End Sub

'Si tu veux les 6 premiers tu mets 6
Public Const monMax As Long = 5
Public Cell As Range
Public tab1(1 To monMax, 1 To 18) As Variant
Public tab2(1 To monMax, 1 To 18) As Variant
Public tab3(1 To monMax, 1 To 18) As Variant
Public tab4(1 To monMax, 1 To 18) As Variant
Public tab5(1 To monMax, 1 To 18) As Variant
Public tab6(1 To monMax, 1 To 18) As Variant
Public tab7(1 To monMax, 1 To 18) As Variant
Public Tablo As Variant

Sub LesPremiers()
'Macro moins rapide que la précédente à cause des trois boucles imbriquées
'Mais intéressante pour l'utilisation de tableaux
Dim a, b, c, d, e, f, g As Integer

'on "fige" l'écran
Application.ScreenUpdating = False

'on initialise le compteur
a = 0: b = 0: c = 0: d = 0: e = 0: f = 0: g = 0:  l = 2

'on recherche la dernière ligne de la colonne E
DerLi = Sheets("TOURNOI").Columns(5).Find("*", , , , , xlPrevious).Row

'le tableau de tableaux, M E R C I  à Épaf
Tablo = Array("", tab1, tab2, tab3, tab4, tab5, tab6, tab7)

For Each Cell In Sheets("TOURNOI").Range("E3:E" & DerLi)
  'on évalue le premier caractère
  Select Case Left(Cell.Value, 1)
    Case 1: If a < monMax Then RemplirTableaux a, 1   'voir la macro plus bas
    Case 2: If b < monMax Then RemplirTableaux b, 2
    Case 3: If c < monMax Then RemplirTableaux c, 3
    Case 4: If d < monMax Then RemplirTableaux d, 4
    Case 5: If e < monMax Then RemplirTableaux e, 5
    Case 6: If f < monMax Then RemplirTableaux f, 6
    Case 7: If g < monMax Then RemplirTableaux g, 7
  End Select
  'on applique une condition pour sortir de la boucle
  If a + b + c + d + e + f + g = 7 * monMax Then Exit For
Next Cell

'on efface
Sheets("Serie").Range("A3:R" & 8 + 7 * monMax).ClearContents
    
'la récupération des données avec 3 boucles imbriquées
For i = 1 To UBound(Tablo)
  For j = 1 To monMax ' ou UBound(tab1, 1)
    For k = 1 To UBound(tab1, 2)
      Sheets("Serie").Cells(j + l, k).Value = Tablo(i)(j, k)
    Next k
  Next j
  l = l + monMax + 1 ' + 1 pour sauter une ligne
Next i
' on actualise l'écran
Application.ScreenUpdating = True
End Sub
Sub RemplirTableaux(Lettre, Pos)
    Lettre = Lettre + 1
    For i = 1 To 18
      Tablo(Pos)(Lettre, i) = Sheets("TOURNOI").Cells(Cell.Row, i).Value
    Next
End Sub