Copier des lignes vers une liste à partir d'une cellule remplie

Bonjour,

Je cherche à améliorer un outil de calcul (remplissage franco tonnage camion) pour mes clients.

Dans ce fichier, mes clients remplissent la quantité de palettes souhaitée pour chaque produit. (Colonne G en jaune car modifiable par mon client) Ensuite, j'aimerai que les informations de ce produit [ Intitulé, Référence Interne, nombre de palettes et poids total soit colonne A B G et H] se transfèrent sur l'onglet "Calculatrice" à partir de ligne 13. Ces informations se listent au fur et à mesure que les case G se remplissent.

Pour information : ceci me permettra de valider la commande par rapport au tonnage puis de faire de ce document un bon de commande.

Par avance merci

Bonne journée

Yohann T.

Bonjour,

Complexe ... Surtout avec les feuilles protégées qui ne laissent que peu de marge de manœuvre. Cependant à insérer dans le module ThisWorkbook :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim REF$, TROUVE_REF As Object, LR%, L(0 To 3)
If Sh.Name = "Bordurettes" Or Sh.Name = "Dalles" Then
    REF = Target.Offset(, -5)
    If Not Application.Intersect(Target, Sh.Columns(7)) Is Nothing And Target.Offset(, -1) <> "" And IsNumeric(Range(Target.Address).Cells(1, 1)) = True And REF <> "" Then
        L(0) = Target.Offset(, -6)
        L(1) = Target.Offset(, -5)
        L(2) = Target
        L(3) = Target.Offset(, 1)
        With Worksheets("CALCULATRICE")
            Set TROUVE_REF = .Columns(2).Find(REF)
            If Not TROUVE_REF Is Nothing Then
                .Cells(TROUVE_REF.Row, 1).Resize(1, 4) = L
                Else
                LR = .[A11].End(xlDown).Row + 1
                .Cells(LR, 1).Resize(1, 4) = L
            End If
        End With
    End If
    If Not Application.Intersect(Target, Sh.Columns(7)) Is Nothing And REF <> "" And Range(Target.Address).Cells(1, 1) = "" Then
        Set TROUVE_REF = Worksheets("CALCULATRICE").Columns(2).Find(REF)
        Worksheets("CALCULATRICE").Rows(TROUVE_REF.Row).ClearContents
    End If
End If
End Sub

Ce code fonctionne et s'est très largement complexifié à cause de vos fusionnées, ce qui est d'ailleurs très largement déconseillé sur EXCEL.

Cdlt,

Bonjour,

Merci pour votre réponse.

Etant débutant sur Excel (autodidacte surtout), je peux :

- supprimer les cellules fusionnées,

- retirer la protection pour votre aide, (je l'ai mise en place uniquement pour mes clients)

- Comment et où dois-je insérer ce module?

- Comment le compléter sachant que mon dossier complet comprend 9 onglets :"Bordurettes, Dalles, PavéJardin, PavésVoirie, PiliersClôtures, SacsPrélinteau, RegardsTuyaux, Blocs, FindesStocks" (Nommés dans cette orthographe)

Encore merci du temps passé à m'aider.

Yohann T.

Bonjour,

Normalement si votre classeur est similaire, alors on vérifie juste que la valeur modifiée Target n'est pas sur la feuille CALCULATRICE avant d'executer le code donc :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim REF$, TROUVE_REF As Object, LR%, L(0 To 3)
If Sh.Name <> "CALCULATRICE" Then
    REF = Target.Offset(, -5)
    If Not Application.Intersect(Target, Sh.Columns(7)) Is Nothing And Target.Offset(, -1) <> "" And IsNumeric(Range(Target.Address).Cells(1, 1)) = True And REF <> "" Then
        L(0) = Target.Offset(, -6)
        L(1) = Target.Offset(, -5)
        L(2) = Target
        L(3) = Target.Offset(, 1)
        With Worksheets("CALCULATRICE")
            Set TROUVE_REF = .Columns(2).Find(REF)
            If Not TROUVE_REF Is Nothing Then
                .Cells(TROUVE_REF.Row, 1).Resize(1, 4) = L
                Else
                LR = .[A11].End(xlDown).Row + 1
                .Cells(LR, 1).Resize(1, 4) = L
            End If
        End With
    End If
    If Not Application.Intersect(Target, Sh.Columns(7)) Is Nothing And REF <> "" And Range(Target.Address).Cells(1, 1) = "" Then
        Set TROUVE_REF = Worksheets("CALCULATRICE").Columns(2).Find(REF)
        Worksheets("CALCULATRICE").Rows(TROUVE_REF.Row).ClearContents
    End If
End If
End Sub

Pour l'insertion c'est dans le module ThisWorkbook comme écrit dans mon premier post :

Cdlt,

Bonjour,

Désolé pour le retard mais je vous remercie pour votre aide.

Encore merci pour votre réactivité,