XL 2019 Aide pour un tri "total"

crackerwood

XLDnaute Nouveau
Bonjour la communauté. Je viens vers vous car j'ai un souci de tri. Je sais trier sur une feuille pas de souci la dessus.
Je détaille un peu :
Sur le premier onglet j'ai une liste de nom, prénom avec des données. La je peux trier par nom ou prénom facilement.
Sur le deuxième onglet je récupère la liste de nom et prénom via [="onglet1 A2"] par exemple.
Quand je tri le premier onglet je voudrais que le deuxième onglet fasse le même tri et pareil si j'ai trois, quatre, etc onglet.
Je peux le faire via filtre/trier mais sur les autres onglets ça ne se met pas à jour (sans doute suite à la formule précédente).
Je vous demande donc de l'aide si vous avez le temps bien sûr.
Je vous laisse un fichier exemple en m'excusant car j'ai effacé pas mal de données confidentielle. J'espère que ça ne posera pas de problème.
 

Pièces jointes

  • Test.xlsx
    16.9 KB · Affichages: 17

chris

XLDnaute Barbatruc
Bonjour

Quelle est la finalité opérationnelle de ces copies multiples ?

Il ne faut jamais lier des ID par des formules de type =onglet1!A2

l'ID doit être saisi dans chaque onglet et les autres colonnes par des RECHERCHEV ou EQUIV

Selon la finalité, des requêtes PowerQuery résoudraient...
 

job75

XLDnaute Barbatruc
Bonjour crackerwood, chris,

Voyez le fichier joint et cette macro dans ThisWorkbook :
VB:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, derligF&, derlig&, i&, x$, j&
Set F = Sheets("feuil1")
If TypeName(Sh) <> "Worksheet" Or Sh.Name = F.Name Then Exit Sub
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
derligF = F.Range("A" & F.Rows.Count).End(xlUp).Row
If derligF < 3 Then Sh.Rows("3:" & Sh.Rows.Count).Delete: Exit Sub
derlig = Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = derligF To 3 Step -1
    x = CStr(F.Cells(i, 1))
    If x <> "" Then
        For j = derlig To 3 Step -1
            If CStr(Sh.Cells(j, 1)) = x Then
                Sh.Rows(3).Insert
                Sh.Rows(j + 1).Cut Sh.Rows(3)
                Sh.Rows(j + 1).Delete
                Exit For
            End If
        Next j
        If j = 2 Then 'ajoute la ligne manquante
            Sh.Rows(3).Insert CopyOrigin:=xlFormatFromRightOrBelow 'format du dessous
            Sh.Cells(3, 1) = x
            derlig = derlig + 1
        End If
    End If
Next i
If derlig > derligF Then Sh.Rows(derligF + 1).Resize(derlig - derligF).Delete 'supprime les lignes excédentaires
End Sub
Elle s'exécute quand on active une feuille autre que "feuil1".

A+
 

Pièces jointes

  • Test(1).xlsm
    27.2 KB · Affichages: 4
Dernière édition:

job75

XLDnaute Barbatruc
Une solution plus logique et nettement plus rapide dans ce fichier (2) :
VB:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, derligF&, derlig&, nlig&, i&, x$, ajout As Boolean, j&
Set F = Sheets("feuil1")
If TypeName(Sh) <> "Worksheet" Or Sh.Name = F.Name Then Exit Sub
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
derligF = F.Range("A" & F.Rows.Count).End(xlUp).Row
If derligF < 3 Then Sh.Rows("3:" & Sh.Rows.Count).Delete: Exit Sub
derlig = Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row
nlig = derlig
Application.ScreenUpdating = False
For i = 3 To derligF
    x = CStr(F.Cells(i, 1))
    If x <> "" Then
        ajout = True
        For j = 3 To nlig
            If CStr(Sh.Cells(j, 1)) = x Then
                Sh.Rows(j).Cut Sh.Rows(derlig + 1)
                Sh.Rows(j).Delete
                nlig = nlig - 1
                ajout = False
                Exit For
            End If
        Next j
        If ajout Then 'ajoute la ligne manquante
            Sh.Rows(derlig).AutoFill Sh.Rows(derlig).Resize(2), xlFillFormats 'copie les formats
            derlig = derlig + 1
            Sh.Cells(derlig, 1) = x
        End If
    End If
Next i
Sh.Rows(derligF + 1).Resize(Sh.Rows.Count - derligF).Delete 'supprime les lignes excédentaires
End Sub
Avec des tableaux de 10 000 lignes le code s'exécute chez moi en 73 secondes.
 

Pièces jointes

  • Test(2).xlsm
    24.6 KB · Affichages: 4

job75

XLDnaute Barbatruc
En fait il ne faut pas ignorer les cellules vides s'il y en a, prenez ce fichier (3) :
VB:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, derligF&, derlig&, nlig&, i&, x$, ajout As Boolean, j&
Set F = Sheets("feuil1")
If TypeName(Sh) <> "Worksheet" Or Sh.Name = F.Name Then Exit Sub
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
derligF = F.Range("A" & F.Rows.Count).End(xlUp).Row
If derligF < 3 Then Sh.Rows("3:" & Sh.Rows.Count).Delete: Exit Sub
derlig = Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row
nlig = derlig
Application.ScreenUpdating = False
For i = 3 To derligF
    x = CStr(F.Cells(i, 1))
    ajout = True
    For j = 3 To nlig
        If CStr(Sh.Cells(j, 1)) = x Then
            Sh.Rows(j).Cut Sh.Rows(derlig + 1)
            Sh.Rows(j).Delete
            nlig = nlig - 1
            ajout = False
            Exit For
        End If
    Next j
    If ajout Then 'ajoute la ligne manquante
        Sh.Rows(derlig).AutoFill Sh.Rows(derlig).Resize(2), xlFillFormats 'copie les formats
        derlig = derlig + 1
        Sh.Cells(derlig, 1) = x
    End If
Next i
If nlig > 2 Then Sh.Rows(3).Resize(nlig - 2).Delete 'supprime les lignes excédentaires
End Sub
 

Pièces jointes

  • Test(3).xlsm
    24.8 KB · Affichages: 4

Discussions similaires

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 848
dernier inscrit
Djigbenou