Microsoft 365 Création d'un panier sur valeur supérieur à 0

Gettos

XLDnaute Nouveau
Bonjour à tous,

J'ai créée un catalogue de fourniture de matériels électriques qui pour but d'aider mes collègues à générer leurs demandes d'offres de prix pour les transmettre à nos fournisseurs.
J'ai donc créée plusieurs feuilles qui sont classées par catégories de matériels. Sur ces pages, j'ai mis un bouton pour agrémenter le nombre d'articles souhaiter.
Un autre boutons en haut de la feuille et c'est celui qui me pose problème. Il aura pour but de sélectionner les lignes d'articles et de les envoyer dans la feuille "panier".
J'aimerai que par la même occasion, les cellules "quantité" soient remises à 0 à l'envoi dans la feuilles "panier". Histoire d'éviter qu'à la prochaine utilisation les cellules précédemment modifiées soient recopiées par erreur.
De la même façon que tous les sites marchands sur internet.
Je vous ai mis un extrait du catalogue en PJ.
Je souhaiterais savoir si quelqu'un a une idée sur le code que je pourrais installer sur ce bouton ?
Ps : Je suis débutant sur le codage.

Merci d'avance pour votre aide.
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour Gettos, bienvenue sur XLD,

Voyez le fichier joint et cette macro :
VB:
Sub Panier()
Dim F1 As Worksheet, F2 As Worksheet, s As Shape, lig&, i&
Set F1 = Sheets("Consommables")
Set F2 = Sheets("Panier")
Application.ScreenUpdating = False
For Each s In F1.Shapes
    s.Placement = 1 'déplacer et dimensionner avec les cellules
Next
For Each s In F2.Shapes
    If s.TopLeftCell.Row > 3 Then s.Delete 'supprime les images et compteurs
Next
F2.Rows("4:" & F2.Rows.Count).Delete 'RAZ
lig = 4
With F1.[A1].CurrentRegion
    For i = 3 To .Rows.Count
        If .Cells(i, 9) > 0 Then
            .Rows(i).EntireRow.Copy F2.Cells(lig, 1)
            .Cells(i, 9) = 0 'RAZ
            lig = lig + 1
        End If
    Next
End With
F2.[A3].Copy [A3] 'allège la mémoire
If lig > 4 Then F2.Activate
End Sub
A+
 

Fichiers joints

job75

XLDnaute Barbatruc
S'il y a plusieurs feuilles à copier il suffit de faire une boucle, fichier (2) :
VB:
Sub Panier()
Dim F2 As Worksheet, s As Shape, lig&, F1 As Worksheet, i&
Set F2 = Sheets("Panier")
Application.ScreenUpdating = False
For Each s In F2.Shapes
    If s.TopLeftCell.Row > 3 Then s.Delete 'supprime les images et compteurs
Next s
F2.Rows("4:" & F2.Rows.Count).Delete 'RAZ
lig = 4
For Each F1 In Worksheets
    If F1.Name <> F2.Name Then
        For Each s In F1.Shapes
            s.Placement = 1 'déplacer et dimensionner avec les cellules
        Next s
        With F1.[A1].CurrentRegion
            For i = 3 To .Rows.Count
                If .Cells(i, 9) > 0 Then
                    .Rows(i).EntireRow.Copy F2.Cells(lig, 1)
                    .Cells(i, 9) = 0 'RAZ
                    lig = lig + 1
                End If
            Next i
        End With
    End If
Next F1
F2.[A3].Copy [A3] 'allège la mémoire
If lig > 4 Then F2.Activate
End Sub
 

Fichiers joints

Gettos

XLDnaute Nouveau
Merci @job75 pour la macro. Tout fonctionne très bien.

Je reste admiratif , je n'aurais jamais pu y arriver seul.
Bravo à vous et merci à XLD.
J'ai d'autres projets je ne manquerai pas de revenir vous voir.
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas