Microsoft 365 VBA - rechercher une ligne en fonction de 2 critères sur 2 colonnes différentes

Rhyukane · 21 Novembre 2022

Bonjour, je suis actuellement bloqué sur cette question.

Je reçois un onglet vrac que je mets dans un tableau structuré situé sur un autre onglet
Je dois donc chercher la valeur de la première ligne de la première colonne du tableau structuré dans la première colonne de l'onglet en vrac.
Une fois la valeur trouvé je dois vérifier que la valeur de la seconde colonne de l'onglet vrac est bien aussi égale à celle de la seconde colonne du tableau structuré.
Si c'est bien le cas je copie la valeur de la cellule de la 3e colonne de la ligne identifiée du fichier vrac dans la 3e colonne de la ligne identifiée du tableau structuré.
Si la valeur de la 2e colonne ne correspond pas, alors je cherche l'occurrence suivante de la première ligne du tableau structuré dans l'onglet vrac et ainsi de suite.
Une fois la ligne trouvée ou inexistante, je continue avec la seconde ligne du tableau structuré et ainsi de suite jusqu'à la fin du tableau structuré.

j'ai testé un code mais il ne semble pas fonctionner je vous le mets malgré tout, au cas ou cela pourrait vous aider.

VB:

Sub test()

Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TSD As ListObject 'déclare la variable TSD (Tableau Structuré de destination)

Set CS = ThisWorkbook 'Ouvre l'URL du classeur source en ligne
Set OD = CS.Worksheets("Tableau") 'définit l'onglet destination OD
Set OS = CS.Worksheets("Vrac") 'définit l'onglet source OS
Set TSD = OD.ListObjects("FUP") 'définit le tableau structuré de destination

Dim NbRows As Long 'déclare la variable NbRows (nombre de ligne du fichier source)
Dim i As Integer 'déclare la variable i (ligne en cours de test)
Dim LE As Integer
Dim ZL As String 'déclare une variable de valeur de cellule
Dim c As Range


  OS.Activate

NbRows = OS.Range("B" & Rows.Count).End(xlUp).Row

    For i = 2 To NbRows 'Boucle qui parcours les lignes
    Set c = TSD.ListColumns("Nom").DataBodyRange.Find(OS.Cells(i, 1).Value)
 
    
        If Not c Is Nothing And TSD.ListColumns("Nom").DataBodyRange(LE) = OS.Cells(i, 2).Value Then
LE = c.Row    
 ZL = OS.Cells(i, 3).Value 'défini ZL (Valeur de la cellule "Date de transport prévue (SRDC)" de ligne i)
        TSD.ListColumns("age").DataBodyRange(LE) = ZL 'donne la valeur à la cellule "Auto ETD" du TSD de la ligne correspondant au numéro de VOR de ligne en cours i
  
    Else
 
    Set c = TSD.ListColumns("Nom").DataBodyRange.FindNext(c)
 
    End If 'fin de alcondition Then 'si aucune occurrence n'est trouvée ou si TSD ne contient pas encore de ligne
    Next i 'passe à la ligne suivante de la boucle

 
End Sub 'fin de la macro

Le fichier original est un fichier contenant des informations confidentielles. J'ai donc créé un fichier test qui a le même principe pour que vous puissiez l'utiliser si nécessaire. Je pense que je devrais pouvoir adapter votre code à mon cas.

Merci par avance pour votre aide.

Bonne journée

sylvanu · 21 Novembre 2022

Bonjour Rhyukane,
Pas tout compris,
Que fait on en cas de doublon ?
Par ex Martin Thierry est en ligne 3 et 12.

Rhyukane · 21 Novembre 2022

Oups, j'ai remis à jour le fichier, dans aucun cas il y a des lignes avec les colonnes a et b qui sont équivalentes, j'ai fait mon fichier test trop rapidement. Désolé.

J'ai besoin de trouver :
1/ la ligne avec les colonnes a et b de l'onglet vrac qui correspondent à une ligne avec les mêmes valeurs en colonne a et b dans le tableau structuré
2/ de copier la cellule de la colonne 3 de cette ligne de l'onglet vrac vers la ligne équivalente du tableau structuré.

Il peux y avoir plusieurs lignes avec des valeurs équivalentes en colonne a et en colonne b mais il n'y a y a jamais de doublon sur la combinaison colonne a et b.

J'espère avoir été plus clair.

Merci pour ton aide

sylvanu · 21 Novembre 2022

S'il n'y a jamais de doublons colonnes A et B, on peut le faire sans VBA avec en Tableau C2 :

VB:

=SIERREUR(INDEX(Vrac!C:C;EQUIV(FUP[[#Cette ligne];[Nom]]&FUP[[#Cette ligne];[prénom ]];Vrac!A:A&Vrac!B:B;0));"")

Formule matricielle donc valider avec Maj+Ctrl+Entrée

Rhyukane · 21 Novembre 2022

sylvanu à dit:
S'il n'y a jamais de doublons colonnes A et B, on peut le faire sans VBA avec en Tableau C2 :

VB:

=SIERREUR(INDEX(Vrac!C:C;EQUIV(FUP[[#Cette ligne];[Nom]]&FUP[[#Cette ligne];[prénom ]];Vrac!A:A&Vrac!B:B;0));"")

Formule matricielle donc valider avec Maj+Ctrl+Entrée

J'avais envisagé cette solution mais pour des raisons liées à mon vrai fichier, je suis obligé de passer par du vba :'(

sylvanu · 21 Novembre 2022

Alors un essai en VBA, la macro s'exécute quand on sélectionne la feuille Tableau, avec :

VB:

Sub Worksheet_Activate()
    Dim DL%, TabloVrac, NomTablo$, tablo, i%, j%
    Application.ScreenUpdating = False
    With Sheets("Vrac")
        DL = .Range("A65500").End(xlUp).Row
        TabloVrac = .Range("A2:C" & DL)
    End With
    With Sheets("Tableau")
        NomTablo = .ListObjects(1)
        tablo = .ListObjects(NomTablo).DataBodyRange
    End With
    For i = 1 To UBound(tablo)
        For j = 1 To UBound(TabloVrac)
            If TabloVrac(j, 1) = tablo(i, 1) And TabloVrac(j, 2) = tablo(i, 2) Then
                tablo(i, 3) = TabloVrac(j, 3)
                Exit For
            End If
        Next j
    Next i
    Sheets("Tableau").[FUP[Nom]].Item(1).Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
End Sub

Rhyukane · 21 Novembre 2022

sylvanu à dit:

Alors un essai en VBA, la macro s'exécute quand on sélectionne la feuille Tableau, avec :

VB:

Sub Worksheet_Activate()
    Dim DL%, TabloVrac, NomTablo$, tablo, i%, j%
    Application.ScreenUpdating = False
    With Sheets("Vrac")
        DL = .Range("A65500").End(xlUp).Row
        TabloVrac = .Range("A2:C" & DL)
    End With
    With Sheets("Tableau")
        NomTablo = .ListObjects(1)
        tablo = .ListObjects(NomTablo).DataBodyRange
    End With
    For i = 1 To UBound(tablo)
        For j = 1 To UBound(TabloVrac)
            If TabloVrac(j, 1) = tablo(i, 1) And TabloVrac(j, 2) = tablo(i, 2) Then
                tablo(i, 3) = TabloVrac(j, 3)
                Exit For
            End If
        Next j
    Next i
    Sheets("Tableau").[FUP[Nom]].Item(1).Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
End Sub

Cela semble fonctionner parfaitement.
Je pense comprendre les grandes lignes du code et pouvoir l'adapter à mon cas. Si ce n'est pas le cas je me permettrai de reposter ici.
En tout cas un grand merci pour ton aide et ta rapidité.

Bonne soirée

sylvanu · 21 Novembre 2022

Nouvelle PJ.
Dans la première, si un nom n'existait pas, la valeur de la colonne 3 était conservée. Là, c'est corrigé.

Rhyukane · 23 Novembre 2022

Bonjour Sylvanu, merci beaucoup pour ton retour et cette modification . Désolé pour le temps de réponse, je n'ai pas eu le temps de tester l'application de ma macro à mon vrai fichier. Cela fonctionne très bien.

Par contre, mon vrai fichier a plusieurs colonnes en plus à gauche des colonnes présentes dans le fichier vrac (je n'avais pas précisé cette info ne pensant pas que cela aurait un impact).
Or quand je fais l'import, cela vide mes colonnes à gauches de celles existantes dans le fichier vrac.
Je pense que cela est lié à la dernière ligne de code mais je ne sais pas comment la modifier pour éviter cela.

Aurais tu une piste stp ?

Merci encore pour ton aide.

Bonne journée

sylvanu · 23 Novembre 2022

Bonjour,
Rien compris.
1- Dan la feuille Vrac, le tableau commence en colonne A, comment peut il y avoir des colonnes à gauche de celui ci ?
2- Le code ne touche jamais à la feuille Vrac, il ne fait que prendre les informations, les réagencer et les ranger dans le feuille Tableau.
3- "Or quand je fais l'import, " cela n'a rien à voir avec la macro existante.

Un petit fichier test "vraiment" représentatif serait bien nécessaire.

Microsoft 365 VBA - rechercher une ligne en fonction de 2 critères sur 2 colonnes différentes

Rhyukane

XLDnaute Nouveau

Pièces jointes

sylvanu

XLDnaute Barbatruc

Rhyukane

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Pièces jointes

Rhyukane

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Pièces jointes

Rhyukane

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Pièces jointes

Rhyukane

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Discussions similaires