Trier et copier une liste d'articles

Bonjour,

Je fais à nouveau appel à vous, car je cherche à résoudre le problème suivant :

J'ai une liste d'articles assez longue (onglet 'Balance') et je souhaite qu'ils se recopient automatiquement dans les onglets E, F, G et H en fonction de leur référence (E, F, G ou H).

Actuellement, j'ai fait une macro qui filtre, copie et colle les données (en rouge) dans les onglets.

Cependant, c'est assez lourd et difficile à gérer, car en réalité j'ai de nombreuses données et onglets.

Y a-t-il une possibilité d'automatiser cette "affectation" sans devoir exécuter une macro ?

D'avance merci pour votre aide toujours précieuse !

Bonsoir,

Actuellement, j'ai fait une macro qui filtre, copie et colle les données (en rouge) dans les onglets. On aurait aimé voir cette macro.

Je vous propose une, dites-moi si elle plus rapide que la vôtre.

Sub Repartition()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, DerLig_f2 As Long, Der_Ref As Long, i As Long, NbLig As Long
    Application.ScreenUpdating = False
    Set f1 = Sheets("Balance")
    f1.Select
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    Range("D2:D" & DerLig_f1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("L1"), Unique:=True
    Der_Ref = f1.Range("L" & Rows.Count).End(xlUp).Row
    If f1.AutoFilterMode = False Then f1.Range("A2:E2").AutoFilter
    For i = 2 To Der_Ref
        Feuille = f1.Cells(i, "L")
        Set f2 = Sheets(Feuille)
        DerLig_f2 = f2.Range("J" & Rows.Count).End(xlUp).Row
        f1.Range("A2:E" & DerLig_f1).AutoFilter Field:=4, Criteria1:=f1.Cells(i, "L")
        NbLig = f1.Range("_FilterDataBase").SpecialCells(xlCellTypeVisible).Count - 1
        f1.Range("_FilterDataBase").Offset(1, 0).Resize(NbLig + 2, 5).SpecialCells(xlCellTypeVisible).Copy f2.Range("J" & DerLig_f2 + 1)
    Next i
    f1.Columns(12).ClearContents
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

Merci beaucoup, c'est effectivement beaucoup plus rapide que ce que j'avais essayé de faire !

N'y a-t-il pas une solution, peut-être en VBA, pour que les données se recopient en temps réel dans les onglets, sans devoir lancer une macro ?

Cordialement.

Bonjour,

Oui bien sûr, par exemple en faisant un double-clic sur l'une des cellules des colonnes A à D, cela ne recopiera que la ligne concernée.

Macro à copier dans le module de la feuille "Balance":

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim f1 As Worksheet, f2 As Worksheet
    Dim F_Fest As Long, DerLig_f2 As Long
    If Not Intersect(Target, Range("A3:D10000")) Is Nothing And Target.Value <> "" Then
        F_Dest = Cells(Target.Row, "D")
        Set f1 = Sheets("Balance")
        Set f2 = Sheets(F_Dest)
        DerLig_f2 = f2.Range("J" & Rows.Count).End(xlUp).Row
        Range(f1.Cells(Target.Row, "A"), f1.Cells(Target.Row, "E")).Copy f2.Cells(DerLig_f2 + 1, "J")
    End If
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

On peut aussi faire que: la recopie s'effectue juste à près avoir saisi le prix:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim f1 As Worksheet, f2 As Worksheet
    Dim F_Fest As Long, DerLig_f2 As Long
    If Not Intersect(Target, Columns(5)) Is Nothing And Target.Value <> "" Then
        F_Dest = Cells(Target.Row, "D")
        Set f1 = Sheets("Balance")
        Set f2 = Sheets(F_Dest)
        DerLig_f2 = f2.Range("J" & Rows.Count).End(xlUp).Row
        Range(f1.Cells(Target.Row, "A"), f1.Cells(Target.Row, "E")).Copy f2.Cells(DerLig_f2 + 1, "J")
    End If
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

Top, merci !

On s'approche de la solution.

Le problème que j'y vois encore, c'est que si l'utilisateur double-clic plusieurs fois sur la même cellule, les données se recopient plusieurs fois.

Peut-être en faisant que les données se recopient une fois la référence introduite en colonne D, car cela correspondrait à notre méthode de travail (colonne D complétée en dernier) ?

Dans ce cas, si nous corrigeons par la suite la référence introduite en colonne D, est-ce que cela pourrait corriger l'affectation dans l'onglet concerné ?

Cordialement.

Bonjour,

Une autre solution, utilisant le filtre avancé.

Préalable, les onglets ont le même nom que les références.

Le code se déroule lorsqu'on active un des onglets "Référence"

Dans le ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name <> "Balance" Then Call Dispatch(Sh.Name)
End Sub

Et dans un module standard :

Sub Dispatch(WsName As String)
Dim Plg As Range
Application.ScreenUpdating = False
With Sheets("Balance")
    Set Plg = .Range("A2:E" & .Cells(Rows.Count, "A").End(xlUp).Row)
    .Range("Z1").Value = .Range("D2").Value: .Range("Z2") = WsName
    Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("Z1:Z2"), CopyToRange:=Range("J1:N1"), Unique:=False
    .Range("Z1:Z2").Clear
End With
End Sub

Bonne journée

Trop fort, cela correspond exactement à ce que je recherchais !

Un très grand merci pour votre aide !!

Je vais maintenant essayer de comprendre pour adapter à mon fichier :-)

Une bonne journée et encore merci.

PS vive la Bretagne !

Sinon, j'allais vous proposer ceci:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim f1 As Worksheet, f2 As Worksheet
    Dim F_Fest As Long, DerLig_f2 As Long, N° As Long
    If Not Intersect(Target, Range("A3:D10000")) Is Nothing And Target.Value <> "" Then
        F_Dest = Cells(Target.Row, "D")
        N° = Cells(Target.Row, "A")
        Set f1 = Sheets("Balance")
        Set f2 = Sheets(F_Dest)
        DerLig_f2 = f2.Range("J" & Rows.Count).End(xlUp).Row
        'recherche du numéro dans la feuille de destination
        With f2.Range(f2.Cells(1, "J"), f2.Cells(DerLig_f2, "J"))
            Set x = .Find(N°)
            If Not x Is Nothing Then
                Reponse = MsgBox("Cette référence existe déjà, voulez-vous la remplacer?" & Chr(10) & " en cliquant sur OUI, elle sera remplacée " & Chr(10) & " en cliquant sur NON, elle sera ajoutée?", vbYesNo + vbCritical + vbDefaultButton2, "Contrôle des N°")
                If Reponse = vbYes Then
                    Range(f1.Cells(Target.Row, "A"), f1.Cells(Target.Row, "E")).Copy f2.Cells(x.Row, "J")
                Else
                    Range(f1.Cells(Target.Row, "A"), f1.Cells(Target.Row, "E")).Copy f2.Cells(DerLig_f2 + 1, "J")
                End If
            Else
                Range(f1.Cells(Target.Row, "A"), f1.Cells(Target.Row, "E")).Copy f2.Cells(DerLig_f2 + 1, "J")
            End If
        End With
        Range(f1.Cells(Target.Row, "A"), f1.Cells(Target.Row, "E")).Font.Color = RGB(0, 0, 255)
    End If
Sortie:
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Si la référence existe déjà, une boîte de dialogue s'ouvrira et demandera si on ajoute ou remplace la ligne existante

se plus, à chaque double-clic sur une cellule, l'écriture de la ligne du tableau passe en bleu.

Merci beaucoup, je vais également tester et si je n'arrive pas à adapter l'autre solution, peut-être que j'y parviendrai avec celle-ci.

Bonne journée !

Bonjour,

Vous m'avez grandement aidé hier avec un fichier dans lequel je souhaitais trier des articles (onglet Balance) et les affecter dans des onglets (E, F ,G et H).

J'ai essayer de progresser avec mon fichier, mais je constate que si je crée des onglets supplémentaires, les en-têtes (numéro, type d'article,...) se collent également sur les nouveaux onglets (feuil2, feuil01, 01, 02).

Y a-t-il moyen de ne coller les données que sur les onglets E, F, G et H ?

D'avance un grand merci si vous parvenez à m'aider, car cela dépasse mes compétences :-(

Cordialement.

Chris.

Bonjour,

Ceci:

Cdlt

Merci beaucoup.

Je cherchais une solution "automatique", mais à défaut une macro peut faire l'affaire.

En revanche, il y a un problème lors de la reprise des en-têtes de colonnes qui ne suivent pas correctement.

Cordialement.

Bonjour,

Voilà le fichier corrigé:

Cdlt

Bonjour,

Oui, cela fonctionne ainsi !

Merci beaucoup et une bonne journée.

Cordialement.