XL 2010 Comparaison de deux tableaux et suppression de lignes

D

Deliau

XLDnaute Nouveau
Bonjour,

Je dispose de deux tableaux.
Dans le premier (Classeur1) la liste de toutes les routes et ronds-points (ouverts à la circulation) d'une carte.
Dans le second (Classeur2), une liste de chemin empruntant certains de ces routes et ronds-points.

Je souhaite supprimer les chemins du second tableau si l'une des routes ou ronds-points du premier tableau est absente (donc fermé à la circulation).
J'ai codé en VBA une macro me permettant de comparer un à un les éléments du Classeur1 au Classeur2 puis de supprimer les lignes des chemins absents du Classeur2, mais ce ne sera pas optimisé quand le nombre d'éléments à analyser sera important.

Je souhaite savoir si une fonction d'Excel permet ce tri (ou filtrage ou pré sélection) "automatiquement" ?
Voir le fichier attaché pour l'exemple.

Merci,
Lucie
 

Pièces jointes

  • plan.xls
    50.5 KB · Affichages: 15
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Si vous ne savez pas ce qu'est un nom défini : onglet Formules => Gestionnaire de noms.

Cela dit on peut se passer de la MFC et appliquer une couleur de fond, fichier (4) :
VB: 
Private Sub Worksheet_Activate()
Dim dest As Range, d As Object, tablo, i&, ncol%, flag As Boolean, j%, n%
Set dest = [A1] '1ère cellule de destination, à adapter
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
tablo = Feuil1.UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
d("") = "" 'pour inclure les vides
For i = 1 To UBound(tablo)
    d(tablo(i, 1)) = ""
Next
'---tableau des résultats---
With Feuil2.UsedRange
    ncol = .Columns.Count
    If ncol = 1 Then ncol = 2 'pour avoir au moins 2 éléments
    tablo = .Resize(, ncol)
End With
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone 'RAZ
For i = 1 To UBound(tablo)
    If tablo(i, 1) <> "" Then
        flag = False
        For j = 2 To ncol
            If Not d.exists(tablo(i, j)) Then flag = True: dest(i, j).Interior.ColorIndex = 44 'couleur de fond orange
        Next j
        If flag Then
            n = n + 1
            For j = 1 To ncol
                tablo(n, j) = tablo(i, j)
            Next j
        End If
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est fimtrée
With dest
    If n Then .Resize(n, ncol) = tablo
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1).EntireRow.ClearContents 'RAZ en dessous
    .Offset(, ncol).Resize(, .Parent.Columns.Count - ncol - .Column + 1).EntireColumn.ClearContents 'RAZ à droite
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub
Sur un grand tableau c'est peut-être plus rapide qu'avec une MFC.
 

Pièces jointes

  • plan(4).xls
    72.5 KB · Affichages: 4
Vote positif 0 Vote négatif
Patrice33740

Patrice33740

XLDnaute Impliqué
Bonjour,

Un essai :
VB: 
'Ajouter une référence à Microsoft Scripting Runtime
Option Explicit
Sub VerifierChemin()
Dim d As New Dictionary
Dim t As Variant
Dim r As String
Dim v As String
Dim a As String
Dim i As Long
Dim j As Long
Dim m As Long
  'Routes ouvertes
  t = Worksheets("Classeur1").Range("A1").CurrentRegion.Value
  For i = LBound(t) To UBound(t)
    d(t(i, 1)) = ""
  Next i
  'Chemins à vérifier
  t = Worksheets("Classeur2").Range("A1").CurrentRegion.Offset(0, 1).Value
  For i = LBound(t) To UBound(t)
    For j = LBound(t, 2) To UBound(t, 2)
      If Not IsEmpty(t(i, j)) Then
        If Not d.Exists(t(i, j)) Then
          a = Cells(i, j + 1).Address
          ' mémoriser les voies fermées
          v = v & "," & a
          If i <> m Then
            ' mémoriser les chemins fermés
            r = r & "," & i & ":" & i
            m = i
          End If
        End If
      End If
    Next j
  Next i
  v = Mid(v, 2)
  r = Mid(r, 2)
  If Not r = "" Then
    Worksheets("Classeur3").Cells.Clear
    With Worksheets("Classeur2")
      ' Mettre les voies fermées en couleur
      .Range(v).Interior.Color = vbYellow
      With .Range(r)
        ' Copier les chemins fermés vers Classeur3
        .Copy Worksheets("Classeur3").Range("A1")
        ' Effacer les chemins fermés dans Classeur2
        .Delete
      End With
    End With
  End If
End Sub
 

Pièces jointes

  • plan.xls
    63 KB · Affichages: 4
Vote positif 0 Vote négatif
D

Deliau

XLDnaute Nouveau
job75 à dit:
Si vous ne savez pas ce qu'est un nom défini : onglet Formules => Gestionnaire de noms.

Cela dit on peut se passer de la MFC et appliquer une couleur de fond, fichier (4) :
VB: 
Private Sub Worksheet_Activate()
Dim dest As Range, d As Object, tablo, i&, ncol%, flag As Boolean, j%, n%
Set dest = [A1] '1ère cellule de destination, à adapter
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
tablo = Feuil1.UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
d("") = "" 'pour inclure les vides
For i = 1 To UBound(tablo)
    d(tablo(i, 1)) = ""
Next
'---tableau des résultats---
With Feuil2.UsedRange
    ncol = .Columns.Count
    If ncol = 1 Then ncol = 2 'pour avoir au moins 2 éléments
    tablo = .Resize(, ncol)
End With
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone 'RAZ
For i = 1 To UBound(tablo)
    If tablo(i, 1) <> "" Then
        flag = False
        For j = 2 To ncol
            If Not d.exists(tablo(i, j)) Then flag = True: dest(i, j).Interior.ColorIndex = 44 'couleur de fond orange
        Next j
        If flag Then
            n = n + 1
            For j = 1 To ncol
                tablo(n, j) = tablo(i, j)
            Next j
        End If
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est fimtrée
With dest
    If n Then .Resize(n, ncol) = tablo
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1).EntireRow.ClearContents 'RAZ en dessous
    .Offset(, ncol).Resize(, .Parent.Columns.Count - ncol - .Column + 1).EntireColumn.ClearContents 'RAZ à droite
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub
Sur un grand tableau c'est peut-être plus rapide qu'avec une MFC.
Cliquez pour agrandir...

Merci job75,
1- la règle dans la MFC ne se garde pas dans le classeur actif
2- merci pour la macro plan(4), c'est exactement cela mais il y a un décalage de colorisation quand plusieurs "routes" du Classeur1 appartenant à plusieurs "chemins" sont absents.

Exemple avec les absents suivants :
route1 : bien coloré
route21 : coloriage décalé vers le bas
rondpoint82 : coloriage très décalé vers le bas

Merci
4198F808-75B3-459F-9891-FAA241010DCA.jpeg
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Effectivement le fichier (4) n'allait pas, prenez ce fichier (5) avec :
VB: 
Private Sub Worksheet_Activate()
Dim dest As Range, d As Object, tablo, i&, ncol%, flag As Boolean, j%, n%
Set dest = [A1] '1ère cellule de destination, à adapter
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
tablo = Feuil1.UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
d("") = "" 'pour inclure les vides
For i = 1 To UBound(tablo)
    d(tablo(i, 1)) = ""
Next
'---tableau des résultats---
With Feuil2.UsedRange
    ncol = .Columns.Count
    If ncol = 1 Then ncol = 2 'pour avoir au moins 2 éléments
    tablo = .Resize(, ncol)
End With
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone 'RAZ
For i = 1 To UBound(tablo)
    If tablo(i, 1) <> "" Then
        flag = False
        For j = 2 To ncol
            If Not d.exists(tablo(i, j)) Then
                If Not flag Then flag = True: n = n + 1
                dest(n, j).Interior.ColorIndex = 44 'couleur de fond orange
            End If
        Next j
        If flag Then
            For j = 1 To ncol
                tablo(n, j) = tablo(i, j)
            Next j
        End If
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est fimtrée
With dest
    If n Then .Resize(n, ncol) = tablo
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1).EntireRow.ClearContents 'RAZ en dessous
    .Offset(, ncol).Resize(, .Parent.Columns.Count - ncol - .Column + 1).EntireColumn.ClearContents 'RAZ à droite
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub
Edit : pour ce qui est de la MFC du fichier (3 bis) pas de problème chez moi.

Une fois la MFC créée sur les colonne B:S ne supprimez pas des cellules, effacez-les.
 

Pièces jointes

  • plan(5).xls
    72 KB · Affichages: 7
Dernière édition:
Vote positif 0 Vote négatif
D

Deliau

XLDnaute Nouveau
job75 à dit:
Effectivement le fichier (4) n'allait pas, prenez ce fichier (5) avec :
VB: 
Private Sub Worksheet_Activate()
Dim dest As Range, d As Object, tablo, i&, ncol%, flag As Boolean, j%, n%
Set dest = [A1] '1ère cellule de destination, à adapter
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
tablo = Feuil1.UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
d("") = "" 'pour inclure les vides
For i = 1 To UBound(tablo)
    d(tablo(i, 1)) = ""
Next
'---tableau des résultats---
With Feuil2.UsedRange
    ncol = .Columns.Count
    If ncol = 1 Then ncol = 2 'pour avoir au moins 2 éléments
    tablo = .Resize(, ncol)
End With
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone 'RAZ
For i = 1 To UBound(tablo)
    If tablo(i, 1) <> "" Then
        flag = False
        For j = 2 To ncol
            If Not d.exists(tablo(i, j)) Then
                If Not flag Then flag = True: n = n + 1
                dest(n, j).Interior.ColorIndex = 44 'couleur de fond orange
            End If
        Next j
        If flag Then
            For j = 1 To ncol
                tablo(n, j) = tablo(i, j)
            Next j
        End If
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est fimtrée
With dest
    If n Then .Resize(n, ncol) = tablo
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1).EntireRow.ClearContents 'RAZ en dessous
    .Offset(, ncol).Resize(, .Parent.Columns.Count - ncol - .Column + 1).EntireColumn.ClearContents 'RAZ à droite
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub
Edit : pour ce qui est de la MFC du fichier (3 bis) pas de problème chez moi.

Une fois la MFC créée sur les colonne B:S ne supprimez pas des cellules, effacez-les.
Cliquez pour agrandir...

Parfait, merci job75 et les autres :)
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Deliau, le forum,

Pour tester les durées d'exécution de la macro dans la feuille Lignes supprimées j'ai copié le tableau de la feuille Classeur2 sur 50 000 lignes :

- fichier (3 bis) avec la MFC => 1,5 seconde

- fichier (5) => 2,1 secondes.

Contrairement à ce que je pensais la MFC est plus rapide.

PS : j'avais déclaré n As Integer (n%) il faut bien sûr déclarer n As Long (n&) dans les 2 macros.

A+
 
Vote positif 0 Vote négatif
D

Deliau

XLDnaute Nouveau
job75 à dit:
Effectivement le fichier (4) n'allait pas, prenez ce fichier (5) avec :
VB: 
Private Sub Worksheet_Activate()
Dim dest As Range, d As Object, tablo, i&, ncol%, flag As Boolean, j%, n%
Set dest = [A1] '1ère cellule de destination, à adapter
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
tablo = Feuil1.UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
d("") = "" 'pour inclure les vides
For i = 1 To UBound(tablo)
    d(tablo(i, 1)) = ""
Next
'---tableau des résultats---
With Feuil2.UsedRange
    ncol = .Columns.Count
    If ncol = 1 Then ncol = 2 'pour avoir au moins 2 éléments
    tablo = .Resize(, ncol)
End With
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone 'RAZ
For i = 1 To UBound(tablo)
    If tablo(i, 1) <> "" Then
        flag = False
        For j = 2 To ncol
            If Not d.exists(tablo(i, j)) Then
                If Not flag Then flag = True: n = n + 1
                dest(n, j).Interior.ColorIndex = 44 'couleur de fond orange
            End If
        Next j
        If flag Then
            For j = 1 To ncol
                tablo(n, j) = tablo(i, j)
            Next j
        End If
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est fimtrée
With dest
    If n Then .Resize(n, ncol) = tablo
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1).EntireRow.ClearContents 'RAZ en dessous
    .Offset(, ncol).Resize(, .Parent.Columns.Count - ncol - .Column + 1).EntireColumn.ClearContents 'RAZ à droite
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub
Edit : pour ce qui est de la MFC du fichier (3 bis) pas de problème chez moi.

Une fois la MFC créée sur les colonne B:S ne supprimez pas des cellules, effacez-les.
Cliquez pour agrandir...

Bonjour le forum, job75,

Je me retrouve finalement avec un grand nombre de route non vues et donc colorisées.
Comment les regrouper dans une autre feuille pour les analyser ?

Merci,
Lucie
 
Vote positif 0 Vote négatif
D

Deliau

XLDnaute Nouveau
Si je reprends l'image utilisée plus haut (et en PJ), "route 1" et "route 81" sont colorées car absentes de l'autre feuille. C'est parfait.
Mais comme j'en ai beaucoup dans ce cas dans mon fichier, je souhaite les regrouper dans une nouvelle feuille, ou apparaitrait dans une colonne :
"route 1"
"route 81"
Etc ...

Merci.
 

Pièces jointes

  • B30DDDBA-F4E4-4A89-B78D-A8D541B66DDE.jpeg
    B30DDDBA-F4E4-4A89-B78D-A8D541B66DDE.jpeg
    66.3 KB · Affichages: 6
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Voyez ce fichier (6) - suite du fichier (5) - et la feuille "Manquants" avec le code :
VB: 
Private Sub Worksheet_Activate()
ReDim Manquants(1 To Rows.Count, 1 To 1)
Feuil4.Lignes_supprimees 'lance la macro de la feuille précédente
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
    If Nmanque Then .Resize(Nmanque) = Manquants
    .Offset(Nmanque).Resize(Rows.Count - Nmanque - .Row + 1).ClearContents 'RAZ en dessous
End With
With UsedRange: End With 'actualise les barres de défilement
'---RAZ des variables mémorisées---
Nmanque = 0
Manquants = Empty
End Sub
Les variables Nmanque et Manquants sont déclarées Public dans Module1 pour être mémorisées.

Dans la feuille "Ligne supprimées" le code a été revu avec cette ligne supplémentaire :
VB: 
If IsArray(Manquants) Then Nmanque = Nmanque + 1: Manquants(Nmanque, 1) = tablo(i, j) 'liste des manquants pour la feuille suivante
 

Pièces jointes

  • plan(6).xls
    84.5 KB · Affichages: 5
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
XL 2013 Macro qui compare deux tableaux et supprime des lignes selon un critère.
Réponses
4
Affichages
260
manu49300
M
L
  • Question
Microsoft 365 Comparaison des cellules de deux tableaux avec les fonctions recherchev et/ou ESTNA
Réponses
9
Affichages
181
chris
chris
D
  • Résolu(e)
XL 2021 VBA - Copies de données entre deux tableaux structurés avec plusieurs conditions
Réponses
5
Affichages
441
Drapela
D
D
  • Question
XL 2010 fond blanc et gris dans plusieurs tableaux
Réponses
1
Affichages
330
TooFatBoy
TooFatBoy
M
  • Résolu(e)
Microsoft 365 Copier/coller - Ajout/suppression lignes automatiques
Réponses
6
Affichages
728
M.Ben
M
L
  • Question
Power Query groupés deux tableaux qui existent sur la même feuille et ajout d'information supplémentaire
Réponses
7
Affichages
630
Aurelili
A
D
  • Question
Microsoft 365 macro suppression de lignes dans un tableau
Réponses
3
Affichages
522
Hasco
Hasco
G
  • Question
Microsoft 365 Transfert de données
Réponses
7
Affichages
350
GClaire
G
L
  • Question
XL 2016 Macro et suppressions de lignes
Réponses
9
Affichages
609
fanfan38
fanfan38
D
  • Question
Autres Un exemple de résultats pour un examen de secourisme
Réponses
7
Affichages
767
delta6x
D

Membres actuellement en ligne

17 membres et 129 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 216
Messages
2 086 340
Membres
103 192
dernier inscrit
Corpdacier