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

YANNISE

XLDnaute Nouveau
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

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

Pièces jointes

  • V2.00_VBA_REF_EXISTE.xlsm
    21.5 KB · Affichages: 9
Solution
Bonjour Yannise,

Ton histoire parait compliquée et pas très claire, mais essaie tout de même cela:
VB:
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)...

patty58

XLDnaute Junior
Bonjour Yannise,

Ton histoire parait compliquée et pas très claire, mais essaie tout de même cela:
VB:
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
 

Discussions similaires

Réponses
9
Affichages
362