XL 2021 Boucle sur deux feuilles

[dadaze]

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]

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é :

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 :

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

Application.ScreenUpdating = True

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

 

[mapomme]

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.

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]

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

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]

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

=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)

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

Bonne journée

 

[dadaze]

Bonsoir,
Une possibilité :

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 :

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

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]

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

=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)

=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]

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

=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)

=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]

Bonsoir,
Une possibilité :

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 :

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

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]

Bonsoir,
Une possibilité :

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 :

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

Application.ScreenUpdating = True

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

Merci beaucoup

 

[job75]

2 remerciements chacun pour Gégé et Cousinhub.

Rien pour mapomme et job75.

On s'en souviendra.

 

[dadaze]

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