Probleme de calcul en VBA lié a une liste deroulante

Bonjour je deviens folle a tourner autour d'un problème je ne trouve pas la solution qq'un peut il m'aider svp.

voici mes contraintes :

mon tableau comporte 7 colonnes

colonne A Référence (obtenu en vba par double clique selon un catalogue dans des onglets différents)

colonne B désignation (obtenu par vba VLookup)

colonne C une quantité à noter manuellement

colonne D un prix achat (obtenu par vba VLookup)

colonne E une marge qui est une liste déroulante de 1, 0,60, 0,50 etc...

colonne F le résultat que je souhaiterai en calcul automatique en VBA avec une formule de type : range (d:d) / range (e:e) sachant que le E est variable à cause de la liste déroulante.

colonne G (et la j'exagère… ) faire un calcul automatique qui multiplie la cellule quantité par le résultat obtenu dans F.

voici un extrait de mon tableau

Bonjour,

Tu dresses une liste de 7 contraintes ...

Mais a priori ...

1. Ton onglet DEVIS ne contient pas ce que tu décris comme contraintes

et

2. Aucune macro ... donc difficile de deviner le problème en VBA ...

bonjour Mr Bond

j'ai de la prog vba dans feuil3 pour le double clic

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Interior.ColorIndex = 6 Then

Cancel = True

Sheets("DEVIS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Target

MsgBox "Référence copiée"

End If

If Target.Interior.ColorIndex = 3 Then

Cancel = True

Sheets("DEVIS").Range("G" & Rows.Count).End(xlUp).Offset(1, 0) = Target

MsgBox "Référence copiée"

End If

If Target.Interior.ColorIndex = 45 Then

Cancel = True

Sheets("DEVIS").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0) = Target

MsgBox "Référence copiée"

End If

End Sub

et vba à nouveau dans feuil "DEVIS" pour le Vlookup et clear c'est dans cette feuille que je souhaite rajouter un calcul auto.

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("A2:A50")) Is Nothing And Target.Count = 1 Then

Application.EnableEvents = False

On Error Resume Next

Cells(Target.Row, 4).ClearContents

Cells(Target.Row, 4).Value = Application.WorksheetFunction.VLookup(Target.Value, Sheets("TARIF").Range("TARIF"), 3, False)

On Error GoTo 0

Application.EnableEvents = True

End If

Application.EnableEvents = False

On Error Resume Next

Cells(Target.Row, 2).ClearContents

Cells(Target.Row, 2).Value = Application.WorksheetFunction.VLookup(Target.Value, Sheets("TARIF").Range("TARIF"), 2, False)

On Error GoTo 0

Application.EnableEvents = True

End Sub

Sub Clearcells()

'Updateby Extendoffice 20161008

Range("A2", "A30").Clear

Range("B2", "B30").Clear

Range("C2", "C30").Clear

Range("D2", "D30").Clear

End Sub

merci

Re,

Concernant la feuille Architectural ... le double-click ...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 1 Then Exit Sub
  With Sheets("DEVIS")
    Select Case Target.Interior.ColorIndex
        Case 3
          .Range("G" & Rows.Count).End(xlUp).Offset(1, 0) = Target
        Case 6
          .Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Target
        Case 45
          .Range("Q" & Rows.Count).End(xlUp).Offset(1, 0) = Target
    End Select
  End With
MsgBox "Référence copiée"
Cancel = True
End Sub