Créer une Liste + Créer une condition associé à cette liste

Bonjour,

Je dispose de numéro dans ma colonne A et d'une base de donnée de numéro dans ma colonne G.

Les numéros de la colonne A sont uniques. Ces numéros existe dans la colonne G et en plusieurs fois (c'est normal)

Je souhaite supprimer l'ensemble des numéros de la colonne G qui n'existe pas dans la colonne A.

J'ai tenté de créer une boucle, mais celle-ci ne fonctionne pas (voir ci-dessous). De plus le temps d'exécution est conséquent.

    'Déclaration de variables
    Dim LigneTotal As Long
    Dim LigneActuelle As Long
    Dim i As Long
    Dim j As Long
    Dim NbAffaire As Long
    Dim Affaire As String

    NbAffaire = Range("A65536").End(xlUp).Row

    LigneTotal = ActiveSheet.UsedRange.Rows.Count
    LigneActuelle = LigneTotal

    For i = LigneTotal To NbAffaire + 2 Step -1
        Affaire = Range("G" & LigneActuelle).Value

        For j = NbAffaire To 2 Step -1
            If Cells(j, 1) <> Affaire Then
                Range("A" & LigneActuelle).EntireRow.Delete
            End If

        Next j
        LigneActuelle = LigneActuelle - 1
    Next i

Edit modo : image supprimée, code mis entre balises inséré à la place

A mon sens il serait plus simple de créer une liste contenant les numéros de la colonne A et ensuite vérifier si les numéros de la colonnes G appartiennent à cette liste. Malheureusement je ne maîtrise pas ces fonctions. Quelqu'un serait-il en mesure de m'aider ?

Je vous joint le fichier.

Merci pour vos réponses.

Bonjour JuSuGar, bonjour le forum,

Peut-être comme ça :

Sub Thautheme()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim TS As Variant 'déclare la variable TS (Tableau Source)
Dim TD As Variant 'déclare la variable TD (Tableau Destination)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim TEST As Boolean 'déclare la variable TEST

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Worksheets("Feuil1") 'définit l'onglet O
TS = O.Range("A1").CurrentRegion 'définit le tableau source TS
TD = O.Range("G13").CurrentRegion 'définit le tableau destination TD
For J = UBound(TD, 1) To 2 Step -1 'boucle 1 : sur toutes les lignes J du tableau destination (en partant de la seconde)
    TEST = False 'réinitialise la variable TEST
    For I = 2 To UBound(TS, 1) 'boucle 2 : sur toutes les lignes I du tableau source (en partant de la seconde)
        If TD(J, 1) = TS(I, 1) Then 'condition : si la donnée ligne J colonne 1 de TD est égale à la donnée ligne I colonne 1 de TS
            TEST = True 'définit la variable TEST
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    If TEST = False Then 'condition : si TEST est [faux]
        O.Cells(J + 12, "G").Delete 'supprime la lige J+ 13 de la colonne G de l'onglet O
    End If 'fin de la condition
Next J 'prochaine ligne de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Données traitées !" 'message de fin
End Sub

Bonjour JuSuGar, ThauThème

Une autre possibilité plus "Easy Learning"

Sub ConditionListe()
  'Déclaration de variables
  Dim fLigG As Long, dLigG As Long, Lig As Long
  Dim CelF As Range
  'On désactive les applications Microsoft
  Application.CutCopyMode = False
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '
  ' Je souhaite supprimer l'ensemble des numéros de la colonne G qui n'existe pas dans la colonne A.
  With Sheets("Feuil1")
    fLigG = .Range("G1").End(xlDown).Row + 1
    dLigG = .Range("G" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne
    For Lig = dLigG To fLigG Step -1
      ' Trouver la ligne dans la colonne A de l'affaire
      Set CelF = Nothing
      Set CelF = .Range("A:A").Find(What:=.Range("G" & Lig), LookIn:=xlValues, LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False)
      ' Si l'affaire n'existe pas supprimer la ligne
      If CelF Is Nothing Then
        .Range("G" & Lig).EntireRow.Delete
      End If
    Next Lig
  End With
  'On réactive les applications Microsoft
  Application.CutCopyMode = True
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

A+

Merci beaucoup pour vos réponses c'est parfait :)

Je me permets de vous resolliciter. Les programmes fonctionnes très bien.

Cependant mon fichier complet contient plus de 160 000 lignes. Cela fait 10min et la macro n'a toujours pas réussi à s'exécuter. L'exécution est toujours en cours. Auriez-vous une solution pour résoudre ce problème de lenteur ?

Re,

Cependant mon fichier complet contient plus de 160 000 lignes

Information que nous n'avions pas eu à l'initiale !
Il aurait-été bien de l'indiquer dès le départ, cela nous aurait évité une perte de temps

Sur l'idée de ThauThème, voici un autre code, on ne travaille qu'en mémoire

Sub ThauthemeBrunoM45()
  Dim J As Long
  Dim Sht As Worksheet
  ' Déclare les Tableaux : TS = Tableau Source, TD = Tableau Destination, TR = Tableau Résultat
  Dim TS As Variant, TD As Variant, TR() As String
  ' Déclare une nouvelle collection pour éviter les doublons
  Dim MaCol As New Collection
  Dim Ind As Long
  ' Définit les variables
  Set Sht = Worksheets("Feuil1")
  TS = Sht.Range("A1").CurrentRegion
  TD = Sht.Range("G13").CurrentRegion
  ' Parcours toutes les lignes
  For J = 2 To UBound(TD, 1)
    ' Trouver la valeur dans le tableau
    If In_Array(TS, TD(J, 1)) Then
      On Error Resume Next
      ' Si valeur trouvée dans tableau source, on l'ajoute à la collection (si possible)
      MaCol.Add CStr(TD(J, 1)), CStr(TD(J, 1))
      ' Si pas d'erreur on conserve
      If Err.Number = 0 Then
        Ind = Ind + 1
        ReDim Preserve TR(Ind)
        TR(Ind) = TD(J, 1)
      Else
        Err.Clear
      End If
    End If
  Next J
  ' Efface les valeurs existantes
  Sht.Range("G13").CurrentRegion.ClearContents
  ' Inscrire celles récupérées
  Sht.Range("H13:H" & 13 + UBound(TR)).Value = Application.Transpose(TR)
End Sub

' https://www.excel-pratique.com/fr/astuces_vba/recherche-tableau-array
Function In_Array(Tableau, Recherche)
  Dim I As Long
  In_Array = False
  For I = LBound(Tableau) To UBound(Tableau)
    ' Si valeur trouvée
    If Tableau(I, 1) = Recherche Then
      In_Array = True
      Exit For
    End If
  Next
End Function

A essayer

Re,

Pardon, je ne pensais psa que cela aurait autant d'impact sur la macro proposer.

Une erreur apparaît lors de l'exécution de la macro que vous venez de proposer

Je ne sais pas d'où cela provient

Re,

Si le tableau de retour est vide, effectivement il peut y avoir l'erreur

Dans ce cas, il faut remplacer

' Efface les valeurs existantes
  Sht.Range("G13").CurrentRegion.ClearContents
  ' Inscrire celles récupérées
  Sht.Range("H13:H" & 13 + UBound(TR)).Value = Application.Transpose(TR)

Par

If Ubound(TR)>0 then
  ' Efface les valeurs existantes
  Sht.Range("G13").CurrentRegion.ClearContents
  ' Inscrire celles récupérées
  Sht.Range("H13:H" & 13 + UBound(TR)).Value = Application.Transpose(TR)
End IF

A+

J'ai réussi à la faire fonctionner.

Précision supplémentaire du coup, les colonnes de D à Z comprennent des données qui sont associées au numéro.

Problème, dans la solutions que vous proposer, le numéro n'est retourné qu'une seule fois or j'aimerais si possible que l'ensemble des apparitions du numéro soit retournées.

Merci encore pour vos propositions et votre temps

Ci-joint un fichier qui contient un échantillon des données

Merci :)

Bonjour,

Une autre solution...

Je ne supprime rien de ta base, je copie les "Affaires" concernées sur une nouvelle feuille via un filtre élaboré..

Regarde si cela convient...

Le code :

Sub Supp_Doublons_Crit()
Dim DerLigG As Long, DerLigA As Long
Dim Plg As Range
DerLigG = Cells(Rows.Count, "G").End(xlUp).Row 'calcul de la dernière ligne colonne G
DerLigA = Cells(Rows.Count, "A").End(xlUp).Row 'calcul de la dernière ligne colonne A
Set Plg = Range("D13:Z" & DerLigG)
Sheets.Add after:=Sheets(Sheets.Count)
Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    Sheets("Feuil1").Range("A1:A" & DerLigA), CopyToRange:=Range("A1"), Unique:=False 'Filtre avancé, nom de Feuil1 à adapter
End Sub

Et le fichier

Bonne fin d'apm

C'est parfait, ça fonctionne comme je le souhaite !

Merci beaucoup pour votre aide