Boucle avec deux Find
Bonjour,
J'ai un petit soucis pour adapter un code que j'ai trouvé sur un forum.
Voilà, j'ai une feuille "Réception" et une feuille "BDD Engagement", dans "Réception" je renseigne un numéro type FA16-001 en C2 et un numéro de ligne type 10,20 ou 30 ... en G2.
De plus, je renseigne des informations en D13, D15, H13, H15 et H17.
J'aimerai qu'à l'aide d'un double Find. , ma macro puisse trouver la ligne correspondant à la combinaison numéro en C2 et ligne en G2 de la feuille "Réception" dans la feuille "BDD Engagement", une fois que celle-ci est trouvé, la macro doit copier les valeurs en D13,D15, ..., H17 pour les coller dans les colonnes correspondantes de "BDD Engagement".
Voici la macro que j'ai tenté d'adapter mais quand je clique sur le bouton, aucune erreur apparaît mais rien ne se passe, je pense que ca concerne l'affectation des valeurs à rechercher.
voici le code :
Sub test()
Dim FL1 As Worksheet
Dim FL2 As Worksheet
Dim Valeur As Variant, c As Range, Valeur2 As Variant, d As Range
Dim NoLigne As Long, DerLig As Long, NoLigne2 As Long, DerLig2 As Long
Set FL1 = Worksheets("BDD Engagement")
Set FL2 = Worksheets("Réception")
NoLigne = 1 'Variable de ligne
Do
If Not Cells(NoLigne, 2) = "" Then
Valeur = Cells(NoLigne, 2) 'Valeur recherchée en 1er : elle est en B1 puis B2, B3 etc... (Numéro)
Valeur2 = Cells(NoLigne, 56) 'Valeur2 recherchée en 2eme : elle est en BD1 puis BD2... (Ligne)
Do
With FL1.Range("B" & NoLigne + 1, [B65536].End(xlUp)) 'Dans la colonne B jusqu'à la dernière cellule non vide
DerLig = 0 'Initialisation dernière ligne
Set c = .Find(Valeur, LookIn:=xlValues, LookAt:=xlWhole) 'Le .Find avec Valeur
If Not c Is Nothing Then 'Si valeur trouvée
If c.Row > NoLigne Then 'Si valeur trouvée autre que valeur de départ
With FL1.Range("BD" & NoLigne + 1, [BD65536].End(xlUp)) 'Dans la colonne BD jusqu'à la dernière cellule non vide
Set d = .Find(Valeur2, LookIn:=xlValues, LookAt:=xlWhole) 'Le .Find avec Valeur2
If Not d Is Nothing Then 'Si valeur2 trouvée
DerLig = c.Row 'Dernière ligne devient celle de la valeur (la 1ère) trouvée
Sheets("Réception").Activate 'Sinon
If Range("D13") <> "" Then 'Si D13 est vide ne rien faire sinon
Range("D13").Copy 'Copier la case
Sheets("BDD Engagement").Activate 'Activer la feuille
Cells(DerLig, 2).Select 'Sélectionner la cellule en B qui correspond à C2
ActiveCell.Offset(0, 55).Select
ActiveCell.PasteSpecial 'Coller D13
'D13 Fait
End If
'Recommence avec D15, D17, H13, H15, H17
Sheets("Réception").Activate
If Range("D15") <> "" Then
Range("D15").Copy
Sheets("BDD Engagement").Activate
Cells(DerLig, 2).Select
ActiveCell.Offset(0, 38).Select
ActiveCell.PasteSpecial
'D15 Fait
End If
Sheets("Réception").Activate
If Range("H15") <> "" Then
Range("H15").Copy
Sheets("BDD Engagement").Activate
Cells(DerLig, 2).Select
ActiveCell.Offset(0, 40).Select
ActiveCell.PasteSpecial
'H15 Fait
End If
Sheets("Réception").Activate
If Range("H13") <> "" Then
Range("H13").Copy
Sheets("BDD Engagement").Activate
Cells(DerLig, 2).Select
ActiveCell.Offset(0, 39).Select
ActiveCell.PasteSpecial
'H13 faiT
End If
Sheets("Réception").Activate
If Range("H17") <> "" Then
Range("H17").Copy
Sheets("BDD Engagement").Activate
Cells(DerLig, 2).Select
ActiveCell.Offset(0, 41).Select
ActiveCell.PasteSpecial
'H19 Fait
End If
Sheets("Réception").Activate
If Range("G2") <> "" Then
Range("G2").Copy
Sheets("BDD Engagement").Activate
Cells(DerLig, 2).Select
ActiveCell.Offset(0, 54).Select
ActiveCell.PasteSpecial
'H19 Fait
End If
Sheets("BDD Engagement").Activate
Cells(DerLig, 2).Select
cde = ActiveCell.Offset(0, 27)
fa = Sheets("Réception").Cells(2, 3)
For I = 2 To 1000
If Sheets("Mouvements").Cells(I + 1, 1) = "" Then
Sheets("Mouvements").Cells(I + 1, 1).Value = "La commande" & cde & " de la " & fa & "a été réceptionnée le " & Date
Exit For
Else
End If
Next
Sheets("BDD Engagement").Visible = False
Sheets("Réception").Activate
Range("C2,D13, D15, h13, H15, H17, G2").Select
Selection.ClearContents 'Supprimer les anciennes valeurs saisies
Application.ScreenUpdating = True
End If
End With
End If
End If
Set c = Nothing 'Et on recommence !
End With
Loop While DerLig > NoLigne 'Tant que Dernière Ligne > Ligne
End If
NoLigne = NoLigne + 1 'Incrémentation
Loop While NoLigne < FL1.Range("B65536").End(xlUp).Row 'On continue jusqu'à la dernière ligne
End SubEn espérant que ce soit assez clair.
Je suis encore novice en vba, j'écris plus à la logique qu'à la connaissance donc si vous voyez d'autres erreurs n'hésitez pas
En vous remerciant.