Lancement d'untri avec ecriture dans plusieurs pages

[Laguich]

Bonjour à tous,
J'ai un classeur avec en feuille 1 une liste de "casier" de A2 à A59.
Une feuille 2 avec des réferences et autres.
Je voudrais faire que pour chaque casier en feuille1 on fasse le tri et extraire chaque ligne correspondante de la feuille 2 et les copier dans la feuille correspondant au le nom du casier.
Pas facile a expliquer.
Peut etre que le code qui ne marche pas mais permet de comprendre je pense les besoins .

Dim LIGNE As Integer
For Each c In Sheets("DATE").Range("a2:a59")
    For Each cc In Sheets("LSCHERRE").Range("c2:c2700")
   ' LIGNE = Sheets(cc).Range("A65536").End(xlUp).Row
        If cc = c Then
                ActiveSheet.Rows.Select
        Selection.Copy
        Sheets(cc).Range(LIGNE, 1).Row.Paste
        End If
        Next cc
        Next c

Merci pour votre aide
fichier mini ligne de la feuille 2 pouvant aller jusqu'à 3500

 

[Modeste]

Re : Lancement d'untri avec ecriture dans plusieurs pages

Bonjour laguich,

Partons du postulat que j'ai correctement compris (ce qui est sujet à caution)...

Il faut ajouter des titres aux colonnes D & E de ta feuille "LSCHERRE", puisque j'utilise les filtres automatiques pour sélectionner les données dans cette feuille.

À ce stade, je ne me suis pas préoccupé de vérifier que chaque feuille correspondant à un "casier" existait bien dans le classeur.

Le contenu des feuilles concernées n'est pas effacé, avant que les nouvelles données y soient collées ... à voir!

Tenant compte de ces remarques, tu peux tester le code suivant, dans un module standard:

Sub répartir()
Application.ScreenUpdating = False
With Sheets("LSCHERRE")
    If Not .AutoFilterMode Then .[A1].CurrentRegion.AutoFilter
    For Each c In Sheets("Date").[A2:A59]
        If .FilterMode Then .ShowAllData
        If Application.CountIf(.[C:C], c) > 0 Then
            .[A1].CurrentRegion.AutoFilter field:=3, Criteria1:=c
            .[A1].CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Sheets("" & c).[A1]
        End If
    Next c
End With
Application.ScreenUpdating = True
End Sub