Rechercher plusieurs valeurs et les copier dans un autre classeur

Bonjour à tous,

Je viens vers vous pour optimisation de macro.

J'ai fait une macro avec des boucles de FIND. Cela fonctionne mais ça s'avère particulièrement long et j'atteint ma limite en terme de connaissance vba.

J'aimerai donc optimiser ma macro.

Pour la décrire, dans l'onglet Sref_DFEM, j'ai la colonne B qui sera toujours rempli et j'ai besoin de trouver l'équivalence des ses chiffres dans l'onglet Group_.Ces chiffres sont présent dans la colonne D de l'onglet Group_..J'ai besoin ensuite que cela me renvoi les chiffres de la colonne A de l'onglet groupe et que cela l'ecrive dans les colonne C: F de l'onglet Sref_DFEM

Si on ne trouve rien, j'ai besoin d'ecrire "other" pour dire que ce chiffre n'est pas dans ce fichier

Je vous copie ma macro actuelle qui fonctionne ainsi qu'un morceau du fichier pour l'exemple

Sub GFEM_DFEM()

Dim cherche As Range
Dim nblignes, nblignessref As Long
Dim i, j, Li, ID As Long

Application.ScreenUpdating = False
Application.DisplayStatusBar = True

Sheets("Group_GFEM_vs_DFEM").Activate
nblignes = Sheets("Group_GFEM_vs_DFEM").Range("D5", Selection.End(xlDown)).Cells.Count
nblignes = nblignes + 4
Sheets("Sref_DFEM").Activate
nblignessref = Sheets("Sref_DFEM").Range("B3", Selection.End(xlDown)).Cells.Count
nblignessref = nblignessref + 2

For i = 3 To nblignessref
    Application.StatusBar = i
    ID = Sheets("Sref_DFEM").Cells(i, 2).Value
    Set cherche = Sheets("Group_GFEM_vs_DFEM").Range("D:D").Find(ID, lookat:=xlPart, LookIn:=xlValues)
    If cherche Is Nothing Then
        Sheets("Sref_DFEM").Cells(i, 3).Value = "Other"
    Else
        Sheets("Sref_DFEM").Cells(i, 3).Value = cherche.Offset(0, -3).Value
        For j = 4 To 6
            Li = cherche.Row
            Set cherche = Sheets("Group_GFEM_vs_DFEM").Range("D" & Li & ":D" & nblignes).Find(ID, lookat:=xlPart, LookIn:=xlValues)
            If cherche Is Nothing Or Sheets("Sref_DFEM").Cells(i, j - 1).Value = cherche.Offset(0, -3).Value Then
            j = 6
            Else
                Sheets("Sref_DFEM").Cells(i, j).Value = cherche.Offset(0, -3).Value
            End If
        Next j
    End If
Next i

Application.ScreenUpdating = True
'Application.DisplayStatusBar = False

End Sub

S

Je vous remercie d'avance

Give

Bonjour,

On peut avoir le résultat à obtenir pour ce fichier SVP

A+

Les colonnes "GFEM ID" , C à F de l'onglet Sref_DFEM contiennent les résultats.

Au départ ces colonnes sont vides. Je ne sais pas non plus dés le départs combien de colonnes vont être remplis. Certains "DFEM ID" de la colonne B (et possiblement présent dans la colonne D de l'onglet Group) peuvent être associés à plusieurs GFEM ID qui sont dans la colonne A de l'onglet Group.

Pour essayer d'être un peu plus claire, c'est une sorte de RechercheV, ou de Index Equiv, ou de FIND. Je cherche une valeur dans un onglet et je la copie dans un autre onglet sauf que j'ai possiblement jusqu'à 4 résultats. Je ne peux donc pas m'arrêter à ma première valeur trouvée, je dois checker s'il existe d'autre valeur et s'il en existe, les copier et les écrire dans l'autre onglet

On ne peut guère faire de miracle hein ! Il y a quand même du monde...

Mébon. La solution suivante est quand même plus rapide :

Option Explicit
Sub GFEM_DFEM()
Dim Y As Boolean
Dim vC&
Dim i&, j&, k&
Dim WsC As Worksheet
Dim ArrS, ArrC
Set WsC = Worksheets("Group_GFEM_vs_DFEM")
ArrS = Worksheets("SRef_DFEM").[B2].CurrentRegion.Value
ArrC = WsC.Range("A4:D" & WsC.Range("D1048576").End(xlUp).Row)
Application.DisplayStatusBar = True
For i = 2 To UBound(ArrS)
   vC = ArrS(i, 1)
   Y = False
   For k = 2 To UBound(ArrC)
      If InStr(ArrC(k, 4), vC) > 0 Then
         Y = True
         Application.StatusBar = i
         For j = 2 To 4
            If ArrS(i, j) = "" Then
               ArrS(i, j) = ArrC(k, 1)
               Exit For
            ElseIf ArrC(k, 1) = ArrS(i, j) Then
               Exit For
            End If
         Next j
      End If
   Next
   If Not Y Then
      For j = 2 To 4
         If ArrS(i, j) = "" Then
            ArrS(i, j) = "Other"
            Exit For
         End If
      Next
   End If
Next
Worksheets("SRef_DFEM").[B2].Resize(UBound(ArrS), UBound(ArrS, 2)) = ArrS
End Sub

A+

EDIT : Macro corrigée pour tenir compte de l'observation suivante.

Je te remercie, cela à bien augmenté la vitesse.

Par contre j'ai encore un soucis, c'est que sur certaine ligne, cela écrit bien "other" pour dire que ça ne trouve pas, et d'autres ligne cela n'ecrit rien au lieu d'ecrire "Other"

Sorry, c'est un aspect de la question que j'avais négligé de vérifier...

La macro ci-dessus a été corrigée pour tenir compte de cette observation.

A+

Je te remercie, c'es parfait!

Je vais bien regarder ton code pour bien le comprendre et l'assimiler.

Merci encore