Amélioré un code VBA

Bonjour,

Je souhaiterais modifier un code pour ajouter une variable.

Explication :

Je souhaiterais ajouter une nouvelle formule "4G7G" qui a une différance au niveau des grammages/personne. Actuellement il y a un code qui fait le calcule automatique (cellules C11:O11 * Cellule B14:B44) quand on double clic dans la cellule qui accueil le résultat mais ne prend pas en conte de variable comme la formule

Voici le document concerner :

Pouvez vous m'aidez ?

Cordialement

bonjour,

une proposition (ajout d'une feuille avec le grammage par formule)

Cells(i, target.Column) = Cells(12, target.Column) * ws.Cells(ligne, col)

et je n'arrive pas a comprendre.

tu peux m'aidez ?

voici le document ci besoin

bonsoir,

j'ai adapté le code à ton classeur

Bonjour,

Je suis désolé mais il semblerais qu'il y est un soucis les colonnes E;M et N ne fonctionne pas et une erreur et apparue dans le code. cette ligne

target = ws.Cells(ligne, col) * Cells(12, target.Column)

De ce code :

Dim col As Byte

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

    If target.Column < 3 Or target.Row < 15 Then Exit Sub
    Cancel = True
    If Not IsNumeric(Cells(target.Column, 12)) Or Not IsNumeric(Cells(2, target.Row)) Then Exit Sub
    If Cells(10, target.Column) < 1 Then Exit Sub
    If target = "" Then
        Set ws = Sheets("Grammage")
        trouve = False
        For col = 1 To ws.Cells(1, Columns.Count).End(xlToLeft).Column
            If UCase(ws.Cells(1, col)) = UCase(Cells(4, target.Column)) Then
                trouve = True
                Exit For
            End If
        Next col
        If Not trouve Then
            MsgBox "La formule " & Cells(4, target.Column) & " non trouvée dans la feuille grammages"
            Exit Sub
        End If
        trouve = False
        For ligne = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row
            If UCase(ws.Cells(ligne, 1)) = UCase(Cells(target.Row, 1)) Then
                trouve = True
                Exit For
            End If
        Next ligne
        If Not trouve Then
            MsgBox "La garniture " & Cells(target.Row, 1) & " non trouvée dans la feuille grammages"
            Exit Sub
        End If
        target = ws.Cells(ligne, col) * Cells(12, target.Column)
    Else
        target.ClearContents
    End If
End Sub

Private Sub worksheet_change(ByVal target As Range)
    If Not Intersect(target, Range("C4:Q4,C10:Q10")) Is Nothing Then
        Set ws = Sheets("Grammage")
        trouve = False
        For col = 1 To ws.Cells(1, Columns.Count).End(xlToLeft).Column
            If UCase(ws.Cells(1, col)) = UCase(Cells(4, target.Column)) Then
                trouve = True
                Exit For
            End If
        Next col
        If Not trouve Then
            MsgBox "La formule " & Cells(4, target.Column) & " non trouvée dans la feuille grammages"
            Exit Sub
        End If
        trouve = False
        For i = 15 To Cells(Rows.Count, 1).End(xlUp).Row
        If UCase(Left(Cells(i, 1), 5)) = "TOTAL" Then Exit Sub
            If Cells(i, target.Column) <> "" And Cells(i, 1) <> "" Then
                For ligne = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row
                    If UCase(ws.Cells(ligne, 1)) = UCase(Cells(i, 1)) Then
                        trouve = True
                        Exit For
                    End If
                Next ligne
                If Not trouve Then
                    MsgBox "La garniture " & Cells(target.Row, 1) & " non trouvée dans la feuille grammages"
                    Exit Sub
                End If
                Cells(i, target.Column) = Cells(12, target.Column) * ws.Cells(ligne, col)
            End If
        Next i
    End If
End Sub

Pouvez vous m'aidez ?

cordialement

bonsoir,

voici

A grand merci a toi