XL 2016 Extraire une ligne des valeurs depuis basse des données vers une autre feuille de travail selon critère

[YANNISE]

Bonjour Forum,
Je me débute sur VBA et je souhaite que vous m’aidiez sur une fonction qui me permet d’extraire des valeurs liées à une cellule sur une autre feuille de travail
Si la valeur de la cellule D1 sur le feuil égale celle sur le feuil *D99999 alors les valeurs sur la même ligne seront copiées sur le feuil mais sur différent cellules
Code ci-après il lui manque quelque chose, vous trouver notamment le fichier Excel ci-joint

Sub Test_vr()

Dim ws_1 As Worksheet
Dim ws_2 As Worksheet
Dim Valeur_Test As String
Dim DerniereLigne As Integer
Dim Lig

Set ws_1 = Worksheets(1)
Set ws_2 = Worksheets(2)

Valeur_Test = ws_1.Cells(1, 4).Value

DerniereLigne = ws_2.Cells(65536, 4).End(xlUp).Row

Set Lig = ws_2.Range(ws_2.Cells(1, 4), ws_2.Cells(DerniereLigne, 1)).Find(Valeur_Test, LookIn:=xlValues, LookAt:=xlWhole)

For i = 4 To DerniereLigne

If Not Lig Is Nothing Then

  ws_2.Range(ws_2.Cells(i, 1), ws_2.Cells(i, 1)).Copy ws_1.Cells(15, 2)
  ws_2.Range(ws_2.Cells(i, 2), ws_2.Cells(i, 2)).Copy ws_1.Cells(15, 4)
  ws_2.Range(ws_2.Cells(i, 3), ws_2.Cells(i, 3)).Copy ws_1.Cells(18, 3)
  ws_2.Range(ws_2.Cells(i, 5), ws_2.Cells(i, 5)).Copy ws_1.Cells(18, 5)

Else
    Exit Sub
    
End If

Next

End Sub

 

[patty58]

Bonjour Yannise,

Ton histoire parait compliquée et pas très claire, mais essaie tout de même cela:

Sub Test_vr()

Dim ws_1 As Worksheet
Dim ws_2 As Worksheet
Dim Valeur_Test As String
Dim DerniereLigne As Integer
Dim Lig

Set ws_1 = Worksheets(1)
Set ws_2 = Worksheets(2)

Valeur_Test = ws_1.Cells(1, 4).Value

DerniereLigne = ws_2.Cells(65536, 4).End(xlUp).Row

Set Rech = ws_2.Columns(4).Find(Valeur_Test)
If Not Rech Is Nothing Then
        Lig = Rech.Row
End If

  ws_2.Range(ws_2.Cells(Lig, 1), ws_2.Cells(Lig, 1)).Copy ws_1.Cells(15, 2)
  ws_2.Range(ws_2.Cells(Lig, 2), ws_2.Cells(Lig, 2)).Copy ws_1.Cells(15, 4)
  ws_2.Range(ws_2.Cells(Lig, 3), ws_2.Cells(Lig, 3)).Copy ws_1.Cells(18, 3)
  ws_2.Range(ws_2.Cells(Lig, 5), ws_2.Cells(Lig, 5)).Copy ws_1.Cells(18, 5)
End Sub

Dis moi

 

[YANNISE]

bonjour patty58,

Un grand merci pour toi le code ca marche parfaitement