Scinder colonne et stocker le résultat sur nouvelle feuille

Bonjour à tous,

J'aimerai prendre les x premières ligne d'une colonnes puis mettre le résultats dans une nouvelle feuille excel. Voici un exemple de la feuille N°1 (colonne A contient le nom des équipes "ANA" et "WAS", les autres colonnes contient un chiffre):

ANA 5 0 0 5 1 0 0 0 3

ANA 0 0 0 5 1 0

ANA 3 0 2 6 9

ANA 0 2 4 8 7 8

WAS 4 5 2

WAS 4 4 0 0 0 0

WAS 6 9 8 0 0 0

WAS 3 6 5 7 7 7

WAS 0 0 0 0 0 2

WAS 3 0 0 0 0

Le but serai que dans la feuille n°2 il y ai :

ANA 5 0 0 5 1 0 0 0 3

ANA 0 0 0 5 1 0

ANA 3 0 2 6 9

ANA 0 2 4 8 7 8

Dans la feuille n°3:

WAS 4 5 2

WAS 4 4 0 0 0 0

WAS 6 9 8 0 0 0

WAS 3 6 5 7 7 7

WAS 0 0 0 0 0 2

WAS 3 0 0 0 0

Comme pour l'exemple ci-dessus, le nombre de ligne par équipe change.

il y 4860 ligne pour 30 équipes donc environ.

Merci de votre aide !

Cordialement,

Quik

Bonjour Quik,

Voici une macro qui fait ça,

Sub Transfert()
Dim Dico As New Scripting.Dictionary
Dim team, sh, Cle As String
Dim LastRw As Long, i As Long, y As Long, rw1 As Long, rw2 As Long

Set sh = Sheets("Team by Team")
LastRw = sh.Cells(Rows.Count, 2).End(xlUp).Row
team = sh.Range("B1:B" & LastRw).Value

For i = LBound(team) To UBound(team)
    Cle = team(i, 1)
    If Not Dico.Exists(Cle) Then Dico.Add Cle, i
Next

For y = LBound(Dico.Keys) To UBound(Dico.Keys)
  If Not y = UBound(Dico.Items) Then
    rw1 = Dico.Items(y)
    rw2 = Dico.Items(y + 1) - 1
  Else
    rw1 = Dico.Items(y)
    rw2 = LastRw
  End If

  Sheets.Add After:=Sheets(Sheets.Count)
  ActiveSheet.Name = Dico.Keys(y)
  sh.Rows(rw1 & ":" & rw2).Copy Range("A1")
  Application.CutCopyMode = False
Next
Set Dico = Nothing
End Sub

Bonjour,

Une autre piste mais il faut que ta feuille principale ("Team by Team") comporte des entêtes de colonnes. A adapter à tes besoins :

Sub Test()

    Dim Plage As Range

    With Worksheets("Team by Team")

        'sur colonne B
        Set Plage = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))

        Plage.AutoFilter 1, "ANA"
        .AutoFilter.Range.EntireRow.Copy Worksheets("Team ANA Intermediaire").Range("A1") '<--- voir pour le nom de la feuille !
        Plage.AutoFilter

        Plage.AutoFilter 1, "WAS"
        .AutoFilter.Range.EntireRow.Copy Worksheets("Team ANA Final").Range("A1") '<--- voir pour le nom de la feuille !
        Plage.AutoFilter

    End With

End Sub

Merci beaucoup à vous deux pour ces deux réponses !

La solution de Theze fonctionne parfaitement

Mais j'ai un souci avec celle de sabV, un message d'erreur apparaît quand je lance la macro (j'ai joint une capture d'écran du message d'erreur).

Merci de votre aide

Bon après-midi

Quik

Bonjour Quik,

Vous devez ajouter la référence à "Microsoft Scripting Runtime"

la création des onglets et le transfert des données se fait en moins de 9 secondes.

Bonjour sabV,

Parfait ça fonctionne parfaitement ! En 1s toutes les feuilles se sont créés !

Merci beaucoup pour ta solution !

Bon après midi

Quik

excellent! merci pour ce retour