XL 2021 Boucle sur deux feuilles

dadaze · 17 Février 2025

Bonjour,

Je teste une macro qui fonctionne bien.

Toutefois, je n'arrive pas à mes fins, je m'explique.

je boucle sur deux feuilles je compare des noms.

Si le nom dans la colonne C de la feuilles "Entrée" existe dans la colonne A de la feuille "Sortie" alors instruction

jusque là tout va bien (voir illustration ci dessous).

If we.Cells(L, 3) = ws.Cells(i, 1) Then

we.Cells(L, 5).Copy

ws.Cells(i, 7).PasteSpecial xlPasteValues

end if

En revanche si le nom dans la colonne C de la feuille "Entrée" n'existe pas dans la colonne A de la feuille "Sortie" donc si la condition n'est pas respectée

je souhaiterais mettre dans la cellule we.Cells(L, 2) ="Aucune correspondance" mais là je vous avoue que je bloque depuis un moment.

Si l'un d'entre vous pourrais m'aider je lui en serais très reconnaissant.

Je joins le fichier

Bien cordialement

Gégé-45550 · 18 Février 2025

dadaze à dit:
Bonjour,

Je teste une macro qui fonctionne bien.

Toutefois, je n'arrive pas à mes fins, je m'explique.

je boucle sur deux feuilles je compare des noms.

Si le nom dans la colonne C de la feuilles "Entrée" existe dans la colonne A de la feuille "Sortie" alors instruction

jusque là tout va bien (voir illustration ci dessous).

If we.Cells(L, 3) = ws.Cells(i, 1) Then

we.Cells(L, 5).Copy

ws.Cells(i, 7).PasteSpecial xlPasteValues

end if

En revanche si le nom dans la colonne C de la feuille "Entrée" n'existe pas dans la colonne A de la feuille "Sortie" donc si la condition n'est pas respectée

je souhaiterais mettre dans la cellule we.Cells(L, 2) ="Aucune correspondance" mais là je vous avoue que je bloque depuis un moment.

Si l'un d'entre vous pourrais m'aider je lui en serais très reconnaissant.

Je joins le fichier

Bien cordialement

Bonsoir,
Une possibilité :

VB:

Sub cible()
Application.ScreenUpdating = False
Dim we As Worksheet, ws As Worksheet
Dim OK As Boolean

Set we = Sheets("Entrée")
Set ws = Sheets("Sortie")
For L = 2 To we.Range("c" & Rows.Count).End(xlUp).Row
    OK = False
    For i = 2 To ws.Range("a" & Rows.Count).End(xlUp).Row
        If we.Cells(L, 3) = ws.Cells(i, 1) Then
            we.Cells(L, 5).Copy
            ws.Cells(i, 7).PasteSpecial xlPasteValues
            OK = True
            Exit For
        End If
    Next i
    If Not OK Then we.Cells(L, 2) = "Aucune correspondance"
Next L
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub

PS :

J'ai ajouté une sortie de boucle (Exit For) lorsque la correspondance est trouvée afin de rendre la procédure plus rapide
J'ai ajouté une dernière ligne :

Code:

Application.ScreenUpdating = True

car il convient de rétablir le rafraîchissement de l'affichage en fin de procédure.
Cordialement,

mapomme · 18 Février 2025

Bonjour à tous🙂,

Une autre méthode avec une seule boucle. Le code est commenté dans le classeur.
Il existe encore d'autres méthodes plus rapides en cas de plusieurs milliers de lignes à traiter.

VB:

Sub cible()
Dim wE As Worksheet, wS As Worksheet, xrgE As Range, xrgS As Range, x, j As Long
   Application.ScreenUpdating = False
   Set wE = Worksheets("Entrée")
   Set xrgE = wE.Range("c2:c" & wE.Range("c" & Rows.Count).End(xlUp).Row)
   Set wS = Worksheets("Sortie")
   Set xrgS = wS.Range("a1:a" & wS.Range("a" & Rows.Count).End(xlUp).Row)
   For Each x In xrgE
      wE.Cells(x.Row, "b").ClearContents
      j = Application.IfError(Application.Match(x, xrgS, 0), 0)
      If j > 0 Then wS.Cells(j, "g") = wE.Cells(x.Row, "e") Else wE.Cells(x.Row, "b") = "Aucune correspondance"
   Next x
   Application.ScreenUpdating = True
End Sub

job75 · 18 Février 2025

Bonjour dadaze, Gégé-45550, mapomme, le forum,

En effet sur de grands tableaux il faut :

- ne pas utiliser .Copy PasteSpecial pour copier les valeurs

- ne pas utiliser 2 boucles imbriquées mais des Dictionary

- travailler sur des tableaux VBA et non pas sur des cellules

Code:

Sub Cible()
Dim we As Worksheet, ws As Worksheet, d As Object, dd As Object, tablo, aucune(), i&, rest(), x$
Set we = Sheets("Entrée")
Set ws = Sheets("Sortie")
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = we.Range("C1:E" & we.Range("C" & Rows.Count).End(xlUp).Row) 'matrice, plus rapide
ReDim aucune(1 To UBound(tablo), 1 To 2)
For i = 2 To UBound(tablo)
    d(tablo(i, 1)) = tablo(i, 3) 'mémorise la valeur
    dd(tablo(i, 1)) = i 'mémorise la ligne
Next i
tablo = ws.[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ReDim rest(1 To UBound(tablo), 1 To 1): rest(1, 1) = ws.[G1]
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    If d.exists(x) Then rest(i, 1) = d(x): aucune(dd(x), 2) = 1 _
        Else rest(i, 1) = "Aucune correspondance"
Next i
For i = 2 To UBound(aucune)
    If IsEmpty(aucune(i, 2)) Then aucune(i, 1) = "Aucune correspondance"
Next i
'---restitution---
we.[B1].Resize(UBound(aucune)) = aucune
ws.[G1].Resize(UBound(rest)) = rest
End Sub

A+

Cousinhub · 18 Février 2025

Bonjour,
Sinon, une formule?
Dans la cellule G2 de l'onglet "Sortie", cette formule dynamique (fonctionne à partir de 2021)

Code:

=RECHERCHEX(A2:A10;Entrée!C2:C12;Entrée!E2:E12;"Aucune correspondance")

Et pour les versions acceptant "RechercheX", mais pas la propagation : (en G2, à recopier vers le bas)

Code:

=RECHERCHEX(A2;Entrée!$C$2:$C$12;Entrée!$E$2:$E$12;"Aucune correspondance")

Bonne journée

dadaze · 18 Février 2025

Gégé-45550 à dit:
Bonsoir,
Une possibilité :

VB:

Sub cible() Application.ScreenUpdating = False Dim we As Worksheet, ws As Worksheet Dim OK As Boolean Set we = Sheets("Entrée") Set ws = Sheets("Sortie") For L = 2 To we.Range("c" & Rows.Count).End(xlUp).Row OK = False For i = 2 To ws.Range("a" & Rows.Count).End(xlUp).Row If we.Cells(L, 3) = ws.Cells(i, 1) Then we.Cells(L, 5).Copy ws.Cells(i, 7).PasteSpecial xlPasteValues OK = True Exit For End If Next i If Not OK Then we.Cells(L, 2) = "Aucune correspondance" Next L Application.CutCopyMode = 0 Application.ScreenUpdating = True End Sub

PS :

J'ai ajouté une sortie de boucle (Exit For) lorsque la correspondance est trouvée afin de rendre la procédure plus rapide

J'ai ajouté une dernière ligne :

Code:

Application.ScreenUpdating = True

car il convient de rétablir le rafraîchissement de l'affichage en fin de procédure.
Cordialement,

Merci beaucoup je teste tout ça
Bien cordialement

dadaze · 18 Février 2025

Cousinhub à dit:
Bonjour,
Sinon, une formule?
Dans la cellule G2 de l'onglet "Sortie", cette formule dynamique (fonctionne à partir de 2021)

Code:

=RECHERCHEX(A2:A10;Entrée!C2:C12;Entrée!E2:E12;"Aucune correspondance")

Et pour les versions acceptant "RechercheX", mais pas la propagation : (en G2, à recopier vers le bas)

Code:

=RECHERCHEX(A2;Entrée!$C$2:$C$12;Entrée!$E$2:$E$12;"Aucune correspondance")

Bonne journée

Merci beaucoup pour votre aide
Bien cordialement

dadaze · 18 Février 2025

Cousinhub à dit:
Bonjour,
Sinon, une formule?
Dans la cellule G2 de l'onglet "Sortie", cette formule dynamique (fonctionne à partir de 2021)

Code:

=RECHERCHEX(A2:A10;Entrée!C2:C12;Entrée!E2:E12;"Aucune correspondance")

Et pour les versions acceptant "RechercheX", mais pas la propagation : (en G2, à recopier vers le bas)

Code:

=RECHERCHEX(A2;Entrée!$C$2:$C$12;Entrée!$E$2:$E$12;"Aucune correspondance")

Bonne journée

Merci beaucoup pour votre aide
Bien cordialement

dadaze · 18 Février 2025

Gégé-45550 à dit:
Bonsoir,
Une possibilité :

VB:

Sub cible() Application.ScreenUpdating = False Dim we As Worksheet, ws As Worksheet Dim OK As Boolean Set we = Sheets("Entrée") Set ws = Sheets("Sortie") For L = 2 To we.Range("c" & Rows.Count).End(xlUp).Row OK = False For i = 2 To ws.Range("a" & Rows.Count).End(xlUp).Row If we.Cells(L, 3) = ws.Cells(i, 1) Then we.Cells(L, 5).Copy ws.Cells(i, 7).PasteSpecial xlPasteValues OK = True Exit For End If Next i If Not OK Then we.Cells(L, 2) = "Aucune correspondance" Next L Application.CutCopyMode = 0 Application.ScreenUpdating = True End Sub

PS :

J'ai ajouté une sortie de boucle (Exit For) lorsque la correspondance est trouvée afin de rendre la procédure plus rapide

J'ai ajouté une dernière ligne :

Code:

Application.ScreenUpdating = True

car il convient de rétablir le rafraîchissement de l'affichage en fin de procédure.
Cordialement,

Merci beaucoup pour votre aide
Bien cordialement

dadaze · 18 Février 2025

Gégé-45550 à dit:
Bonsoir,
Une possibilité :

VB:

Sub cible() Application.ScreenUpdating = False Dim we As Worksheet, ws As Worksheet Dim OK As Boolean Set we = Sheets("Entrée") Set ws = Sheets("Sortie") For L = 2 To we.Range("c" & Rows.Count).End(xlUp).Row OK = False For i = 2 To ws.Range("a" & Rows.Count).End(xlUp).Row If we.Cells(L, 3) = ws.Cells(i, 1) Then we.Cells(L, 5).Copy ws.Cells(i, 7).PasteSpecial xlPasteValues OK = True Exit For End If Next i If Not OK Then we.Cells(L, 2) = "Aucune correspondance" Next L Application.CutCopyMode = 0 Application.ScreenUpdating = True End Sub

PS :

J'ai ajouté une sortie de boucle (Exit For) lorsque la correspondance est trouvée afin de rendre la procédure plus rapide

J'ai ajouté une dernière ligne :

Code:

Application.ScreenUpdating = True

car il convient de rétablir le rafraîchissement de l'affichage en fin de procédure.
Cordialement,

Merci beaucoup

job75 · 18 Février 2025

2 remerciements chacun pour Gégé et Cousinhub.

Rien pour mapomme et job75.

On s'en souviendra.

dadaze · 18 Février 2025

job75 à dit:
2 remerciements chacun pour Gégé et Cousinhub.

Rien pour mapomme et job75.

On s'en souviendra.

Désolé évidemment , Je souhaite remercier tous ceux qui ont consacré quelques instants pour m'aider mapomme et job75 inclus .
Tout à l'heure, fatigué et trop pressé j'ai bugué c'est pourquoi certains ont deux remerciements et d'autres pas.

Donc un grand merci à tous.

Bien cordialement

XL 2021 Boucle sur deux feuilles

dadaze

XLDnaute Nouveau

Pièces jointes

Gégé-45550

XLDnaute Accro

mapomme

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Cousinhub

XLDnaute Barbatruc

dadaze

XLDnaute Nouveau

dadaze

XLDnaute Nouveau

dadaze

XLDnaute Nouveau

dadaze

XLDnaute Nouveau

dadaze

XLDnaute Nouveau

job75

XLDnaute Barbatruc

dadaze

XLDnaute Nouveau

Discussions similaires

XL 2021 Boucle sur deux feuilles

XLDnaute Nouveau

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

Discussions similaires

Privacy & Transparency

Privacy & Transparency