Chercher multiples références en VBA

Le 28/03/2022 à 17:56

Bonjour à tous,

j'ai un fichier Excel avec en feuille1 un tableau contenant 60 colonnes sur plus ou moins 30000 lignes ou l'on retrouve des références au format standard.

J'ai besoin de récupérer toutes les lignes qui contiennent au moins une référence parmi une autre liste de plus ou moins 220 références.

Sur la feuille 2, j'ai copier/coller manuellement les entêtes du mon tableau de la feuille 1. J'ai ajouté les 223 références recherchées dans la colonne BL (avec une entête). En BJ2, j'ai crée une liste déroulante basée sur les 223 références et j'ai ensuite ajouté un bouton qui permet d'exécuter la macro.

Lorsque j'exécute la macro, cela copie toutes les lignes du tableau feuille 1 et colle les lignes dans la feuille 2 et colorie en rouge la cellule où la référence a été retrouvée.

Cela fonctionne correctement, sauf qu'en plus de colorier en rouge la cellule où a été trouvée la référence cela colorie également en noir la cellule suivante (donc la cellule a coté de la cellule en rouge)...mais c'est pas grave je peux m'en accommoder.

J'ai pu faire cette macro grâce aux informations glanées sur le forum ;)

Mais maintenant que j'arrive à récupérer toutes les lignes qui contiennent UNE référence précise parmis les 223 références, j'ai besoin d'effectuer la même recherche mais avec les 223 références d'un coup et l'appliquer en action sur un 2ieme bouton (pour le bouton je pense pouvoir le faire).

Pour cette 2ieme macro, j'ai repris exactement la même que la 1ere macro pour rechercher qu'une SEULE référence sauf que j'ai modifié la ligne :

If cell.Value = Feuil2.Range("BJ2").Value Then par ==> If cell.Value = Feuil2.Range("BL2:BL223").Value Then

mais malheureusement sans succès.

Je suis perdu, pourriez-vous m'apporter un peu d'aide svp ?

Merci par avance.

Option Explicit

Sub Copier()
Dim x As Long
Dim y As Long
Dim cell As Range
Dim rdata As Range

' Déterminer la dernière ligne de la Feuille 1
x = Feuil1.Range("A65536").End(xlUp).Row

' Déterminer la dernière ligne de la Feuille 2 + 1
y = Feuil2.Range("A65536").End(xlUp).Row + 1

' Déterminer la Plage de référence dans la Feuille 1
' à partir de la cellule A2 jusqu'à la cellule BH29406
Set rdata = Feuil1.Range("A2:BH29406")

' Effacer les anciennes lignes des anciennes demandes
If y >= 2 Then Feuil2.Range("A2:BH29406").ClearContents

' Boucle dans la plage de référence
For Each cell In rdata

  ' Si la valeur de la cellule est égale à la
  ' valeur choisie en F2 de la Feuille 2
  If cell.Value = Feuil2.Range("BJ2").Value Then

  ' Dans ce cas, colorier la cellule détectée en rouge
    cell.Offset.Interior.Color = 255

  ' Et, copier depuis la Feuille 1, la plage A:BH
  ' vers la Feuille 2 dans la Colonne A à la premiére ligne libre
    Feuil1.Range("A" & cell.Row & ":BH" & cell.Row).Copy Destination:=Feuil2.Range("A" & y)

  End If
  ' Recalculer la première ligne libre de la Feuille 2
  y = Feuil2.Range("A65536").End(xlUp).Row + 1

' Retour de la boucle pour passer à la cellule suivante
Next cell

End Sub
Le 28/03/2022 à 19:00

Hello,

Voici une façon de faire :

Dim InRef As Boolean
For Each cellulle In [A1:A3]
    InRef = Application.WorksheetFunction.IsNA(Application.VLookup(cellulle, [J1:J2], 1, False))
    If InRef = False Then cellulle.Interior.Color = vbRed
Next cellulle

Boucle sur les valeurs de la plage A1:A3

Recherche si dans la plage J1:J2 la valeur est trouvée.

Si oui, mets en rouge la cellule de la plage A1:A3

Ps : Si tu utilises les couleurs classiques il vaut mieux utiliser les constantes vba

Le 28/03/2022 à 19:53

Hello Rag02700,

Merci pour ta réponse.

12test-excel.xlsm (32.06 Ko)

J'ai tenté d'appliquer ta méthode sur mon 2ième bouton, mais seul les lignes concernant la 1ere référence (parmi une liste de références) sont copiés.

Il y a quelque chose que j'ai dû mal faire, comprendre.

Je joins un fichier (j'aurais pu réduire le nombre de colonnes (60) car, si ca marche pour 10 ca doit être pareil pour 60 ) avec les 2 boutons (bouton1 : macro non modifié / bouton 2 : j'ai appliqué ta méthode).

Encore merci.

Le 28/03/2022 à 21:10

Hello,

Comme ceci :

Sub Copier()
Dim x As Long
Dim y As Long
Dim cell As Range
Dim rdata As Range
Dim InRef As Boolean

' Déterminer la dernière ligne de la Feuille 1
x = Feuil1.Range("A65536").End(xlUp).Row
' Déterminer la dernière ligne de la Feuille 2 + 1
y = Feuil2.Range("A65536").End(xlUp).Row + 1

' Déterminer la Plage de référence dans la Feuille 1
' à partir de la cellule A2 jusqu'à la cellule BH29406
Set rdata = Feuil1.Range("A2:BH29406")

' Effacer les anciennes lignes des anciennes demandes
If y >= 2 Then Feuil2.Range("A2:BH29406").ClearContents

' Boucle dans la plage de référence
For Each cell In rdata

    InRef = Application.WorksheetFunction.IsNA(Application.VLookup(cell, Sheets("Feuil2").Range("BL2:BL5"), 1, False))
    If InRef = False Then cell.Interior.Color = vbRed

Next cell

End Sub
Le 28/03/2022 à 22:46

Ca fonctionne parfaitement bien maintenant avec ce code :

Sub Copier2()
Dim x As Long
Dim y As Long
Dim cell As Range
Dim rdata As Range
Dim InRef As Boolean

' Déterminer la dernière ligne de la Feuille 1
x = Feuil1.Range("A65536").End(xlUp).Row
' Déterminer la dernière ligne de la Feuille 2 + 1
y = Feuil2.Range("A65536").End(xlUp).Row + 1

' Déterminer la Plage de référence dans la Feuille 1
' à partir de la cellule A2 jusqu'à la cellule BH29406
Set rdata = Feuil1.Range("A2:BH1000")

' Effacer les anciennes lignes des anciennes demandes
If y >= 2 Then Feuil2.Range("A2:BH29406").ClearContents

' Boucle dans la plage de référence
For Each cell In rdata

    InRef = Application.WorksheetFunction.IsNA(Application.VLookup(cell, Sheets("Feuil2").Range("BL2:BL5"), 1, False))

    If InRef = False Then
    cell.Interior.Color = vbRed
    Feuil1.Range("A" & cell.Row & ":BH" & cell.Row).Copy Destination:=Feuil2.Range("A" & y)

    ' Recalculer la première ligne libre de la Feuille 2
    End If

    y = Feuil2.Range("A65536").End(xlUp).Row + 1

Next cell

End Sub

En tout cas merci beaucoup pour ton aide, ca m'évite d'avoir a faire la recherche manuellement via le filtre de colonne pour chacune des 223 références soit, 13 380 filtres et copier/coller à faire

Je ferais le test sur le vrai fichier demain.

Rechercher des sujets similaires à "chercher multiples references vba"