Microsoft 365 Code VBA pour choisir entre deux options précalculées dans un classeur

Z

Zonmé

XLDnaute Nouveau
Bonjour à tous, j'ai souvent eu l'occasion d'utiliser ce forum pour trouver réponse à mes questions autour des codes VBA, mais aujourd'hui je bloque et en appelle à vos connaissances!
J'ai créé un fichier excel assez lourd, limite usine à gaz, pour calculer des quantités de produits nécessaires à des projets, en offrant deux options de produits dans la phase de construction du devis en fonction des caractéristiques du projet détaillée sur la même feuille, mais calculées sur d'autre feuilles cachées aux utilisateurs.
J'ai déjà pas mal de macros qui tournent, dont une qui reprend la liste de produits établis sur la feuille 1 et la reporte sur la demande de devis en feuille 2 (la liste d'achat), avec un message d'alerte du type "êtes-vous sur de vouloir rajouter ces produits à votre liste d'achat?".
Cela fonctionne plutôt pas mal, mais par contre je ne trouve pas comment inclure une étape pour choisir entre les deux options proposées par ma feuille de calcul et ainsi n'afficher que la ligne de l'option choisie pour la reporter sur la liste d'achat, sans pour autant effacer les formules de calcules des deux options proposées.
Ce n'est peut être pas très clairement expliqué, mais je me tiens à votre disposition pour plus de renseignement, voire essayer de créer une version simplifié du tableau sans les données confidentielles qu'il contient.
Merci d'avance,
Cédric
 
Dernière édition:
Solution
Phil69970
@Zonmé

Je te propose ce code en remplacement et tu remplaces uniquement cette partie

1707490081109.png


VB: 
Sub AjouterProduits()
Dim Retour As Integer
Retour = MsgBox("Quelle option voulez vous garder ?" & Chr(13) & Chr(10) & _
        "Oui ==> L'option 1" & Chr(13) & Chr(10) & _
        "Non ==> L'option 2" & Chr(13) & Chr(10) & _
        "Annuler ==> On garde les 2", vbYesNoCancel, "Choisir option !")
Select Case Retour
Case 6 'Oui
    ActiveSheet.Range("B74:I77").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("B79:I93").Copy
    With Sheets("Product...
Trier par date Trier par votes
Z

Zonmé

XLDnaute Nouveau
Phil69970 à dit:
Bonjour @Zonmé

Sans fichier représentatif on est proche de la voyance

Regarde la pièce jointe 1190183
Cliquez pour agrandir...
Bonjour Phil, merci pour votre intérêt et réponse!
Je vais travailler sur une version light à publier car j'ai trop d'infos confidentielles sur ma version actuelle..

En gros, j'ai une macro qui me permet déjà de trier les lignes à afficher en me basant sur des valeurs d'une colonne masquée (1 pour afficher, vide pour masquer):

Sub MasquerProdPres()
Debut = 72
Fin = 93
ColNb = 1
For i = Debut To Fin
If Cells(i, ColNb).Value = "" Then
Cells(i, ColNb).EntireRow.Hidden = True
Else
Cells(i, ColNb).EntireRow.Hidden = False
End If
Next i
Application.Goto [B72], True
End Sub

Une fois ce tri effectuer, je peux reporter via une autre macro les lignes conservées sur ma "liste d'achat" dans une autre feuille du classeur.

Je voudrais ajouter une étape permettant de choisir l'option conservée via un pop up avant l'envoi vers la liste d'achat, et ainsi reporter cette valeur de "1" ou "vide" dans la colonne masqué au niveau de la ligne des options concernées.

Je ne sais pas si ça vous aide en attendant la version "light" de mon fichier, mais en tout cas merci pour votre lecture.
Cordialement
 
Vote positif 0 Vote négatif
Z

Zonmé

XLDnaute Nouveau
Zonmé à dit:
Bonjour Phil, merci pour votre intérêt et réponse!
Je vais travailler sur une version light à publier car j'ai trop d'infos confidentielles sur ma version actuelle..

En gros, j'ai une macro qui me permet déjà de trier les lignes à afficher en me basant sur des valeurs d'une colonne masquée (1 pour afficher, vide pour masquer):

Sub MasquerProdPres()
Debut = 72
Fin = 93
ColNb = 1
For i = Debut To Fin
If Cells(i, ColNb).Value = "" Then
Cells(i, ColNb).EntireRow.Hidden = True
Else
Cells(i, ColNb).EntireRow.Hidden = False
End If
Next i
Application.Goto [B72], True
End Sub

Une fois ce tri effectuer, je peux reporter via une autre macro les lignes conservées sur ma "liste d'achat" dans une autre feuille du classeur.

Je voudrais ajouter une étape permettant de choisir l'option conservée via un pop up avant l'envoi vers la liste d'achat, et ainsi reporter cette valeur de "1" ou "vide" dans la colonne masqué au niveau de la ligne des options concernées.

Je ne sais pas si ça vous aide en attendant la version "light" de mon fichier, mais en tout cas merci pour votre lecture.
Cordialement
Cliquez pour agrandir...
Voici le fichier en zip pour respecter la taille des docs transmissibles.
Normalement seuls les onglets "Preservation Estimation Tool" (sur lequel je voudrait inclure la macro au niveau du bouton "Process Products Needs") et l'onglet "My RfQ (la liste d'achat mentionnée).
 

Pièces jointes

  • Preservation - V2 - En cours .zip
    946.2 KB · Affichages: 1
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
Re

@Zonmé
L'anglais n'est pas ma tasse de thé (Anglaise) 🤣

Voici ce que j'ai compris ....

Tu cliques sur le bouton" Process Products Needs" de la feuille "Preservation Estimation Tool" et une macro cache toutes les lignes 72 à 93 qui n'ont pas de 1 en colonnes A
Ceci fonctionne correctement hormis pour les yeux mais facile à corriger.

Mais tu veux copier les cellules visibles entre les lignes 72 à 93 dans la feuille "My RfQ" mais quelle cellules veux tu copier et ou dans la feuille "My RfQ"
Un exemple avec des données aurait été préférables pour mieux comprendre ce que tu veux faire et surtout ou tu veux le faire !!!
Et une fois la copie effectué doit on défiltrer les lignes 72 à 93 ?
Effacer les données de la feuille "Preservation Estimation Tool" entre les lignes 72 à 93 ?
 
Vote positif 0 Vote négatif
Z

Zonmé

XLDnaute Nouveau
Phil69970 à dit:
Re

@Zonmé
L'anglais n'est pas ma tasse de thé (Anglaise) 🤣

Voici ce que j'ai compris ....

Tu cliques sur le bouton" Process Products Needs" de la feuille "Preservation Estimation Tool" et une macro cache toutes les lignes 72 à 93 qui n'ont pas de 1 en colonnes A
Ceci fonctionne correctement hormis pour les yeux mais facile à corriger.

Mais tu veux copier les cellules visibles entre les lignes 72 à 93 dans la feuille "My RfQ" mais quelle cellules veux tu copier et ou dans la feuille "My RfQ"
Un exemple avec des données aurait été préférables pour mieux comprendre ce que tu veux faire et surtout ou tu veux le faire !!!
Et une fois la copie effectué doit on défiltrer les lignes 72 à 93 ?
Effacer les données de la feuille "Preservation Estimation Tool" entre les lignes 72 à 93 ?
Cliquez pour agrandir...
Bonjour Re,

Merci pour ton intérêt.

Je viens de remplir le fichier pour exemple, et vais essayer de mieux détailler mes intentions:

Comment fonctionne le fichier: L'utilisateur rempli uniquement les case en jaune de l'onglet "Preservation Estimation Tool", avec la première partie qui est juste informative.

Les données qui nous intéressent sont celles entrés à partir de la ligne 16 avec :

A - General Information : on renseigne le type et la nature des pièces et les éléments spécifiques au projet.

Cela permet au Bouton “ Process Asset Characteristics ” de trier les infos et lignes à renseigner dans la seconde partie (ligne 34 à 70)



B – Asset Dimensions : ce sont les éléments qui vont nous permettre de faire les calculs de surfaces et volumes dans l’onglet “ Mesures ”

C et D (ligne 47 à 70): ces informations permettent de valider les formules à appliquer dans l’onglet “ Calcul ” et ainsi lister les produits nécessaires dans les cases B73 :J94 de l’onglet “ Preservation ”



Le bouton Process Product Needs sert à finaliser ces calculs, et n’afficher que les lignes non vides dans la section B73 :J93



Une fois que tout est OK, on peut soit décider de rajouter un autre équipement dans le projet ("Add another asset to my Preservation Project"), , soit de dire que c'est bon et on veut aller vers la Liste d'achat “ My RfQ ” (bouton “ I have finished. Review and Print My Request ”).

Ces deux boutons font la même chose en gros, c-à-d copier le contenue de lignes non vides des cellules B72:J93 sur l'onglet "product List" à partir de la ligne 44.



Dans notre exemple, après avoir fait le "Process Product Needs", on a 2 films signalés en options:

Ligne 77 et ligne 78.

J'aimerai inclure dans cette macro ou celle des boutons en bas ("Add another asset to my Preservation Project" et “ I have finished. Review and Print My Request”) la possibilité de choisir laquelle des deux lignes d’options conserver lors de la copie sur l’onglet “Product List“ (par le jeu des valeur 1 ou vide de la colonne masquée A) à travers une fenêtre pop up du style "Vous avez deux options, quelle est celle que vous voulez conserver: 3000mm ou 5000mm de large (width)?".



Voila , j’espère que c’est plus clair ! Par contre je suis ultra preneur aussi de la correction pour nos yeux hehe. Je suis un autodidacte complet sur VBA et suis preneur de tous conseils !

Merci en tout cas pour ton intérêt, et à ta dispo pour plus de précisions !

A++

Zonmé
 

Pièces jointes

  • Preservation - V2 - En cours .zip
    719.9 KB · Affichages: 0
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
Bonjour @Zonmé

Zonmé à dit:
Dans notre exemple, après avoir fait le "Process Product Needs", on a 2 films signalés en options:

Ligne 77 et ligne 78.
Cliquez pour agrandir...
C'est bien ton exemple mais sur ces 2 lignes on a ceci .... quand j'active les macros

1707478632501.png


surement à cause de ce genre de formule fait avec excel 365 et je n'ai que excel 2010

1707478967610.png


Je regarde ce que je peux faire sans garantie


***************

Zonmé à dit:
Par contre je suis ultra preneur aussi de la correction
Cliquez pour agrandir...
Un début de correction
J'ai simplifié le code de la feuille1

1707479228150.png

VB: 
Sub MasquerDimensionsAss()
Debut = 33
Fin = 71
ColNb = 1
For i = Debut To Fin
    If Cells(i, ColNb).Value = "" Then
        Cells(i, ColNb).EntireRow.Hidden = True
    Else
        Cells(i, ColNb).EntireRow.Hidden = False
    End If
Next i
Application.Goto [B34], True
End Sub

Sub MasquerProdPres()
Debut = 72
Fin = 93
ColNb = 1
For i = Debut To Fin
    If Cells(i, ColNb).Value = "" Then
        Cells(i, ColNb).EntireRow.Hidden = True
    Else
        Cells(i, ColNb).EntireRow.Hidden = False
    End If
Next i
Application.Goto [B72], True
End Sub

Sub AjouterProduits()
Dim réponse As Integer
réponse = MsgBox("Do you want to continue? All previous data will be saved for final RfQ.", vbQuestion + vbYesNo)
If réponse = vbYes Then
    ActiveSheet.Range("B74:I93").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("C18").Copy
    With Sheets("Product List").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteValues
    End With
    Range("C16,C18,C20,C22,C24,C26,C28,D35,D37,D39,D41,D43,D45,D49,C51,C53,C56,C58,C60,C62").ClearContents
  Else
    Application.Goto [B34]
  End If
  Application.Goto [B15], True
End Sub

Sub NouvelleDemande()
Dim réponse As Integer
réponse = MsgBox("Do you want to continue? All previous data will be deleted.", vbQuestion + vbYesNo)
If réponse = vbYes Then
    With Worksheets("Preservation Estimation Tool")
        .Range("C5,C7,C9,E5,E7,E9,E11,J5,J7,J9,J11,C16,C18,C20,C22,C24,C26,C28,C30,D35,D37,D39,D41,D43,D45,C49,C51,C53,C56,C58,C60,C62,C68").ClearContents
    End With
    With Worksheets("Product List")
        .Range("B44:I1040").ClearContents
        .Range("A3:A1040").ClearContents
    End With
Else
    Application.Goto [B95]
End If
End Sub

Sub AjouterPrinter()
 ActiveSheet.Range("B74:I93").Copy
With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteColumnWidths
    .PasteSpecial Paste:=xlPasteValues
End With
ActiveSheet.Range("C18").Copy
With Sheets("Product List").Range("a" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteValues
End With
Application.Goto Reference:=Worksheets("My Rfq").Range("B1"), Scroll:=True
End Sub


Et le code de la feuille 9

1707479625620.png


VB: 
Sub MasquerRfQPres()
Debut = 1
Fin = 53
ColNb = 1
For i = Debut To Fin
    If Cells(i, ColNb).Value = "" Then
        Cells(i, ColNb).EntireRow.Hidden = True
    Else
        Cells(i, ColNb).EntireRow.Hidden = False
    End If
Next i
ActiveSheet.Range("B1:H53").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveSheet.Range("C54").Value, OpenAfterPublish:=True
Application.Goto [B1], True
End Sub

Sub tt()
With Worksheets("Preservation Estimation Tool")
    .Range("C5,C7,C9,E5,E7,E9,E11,J5,J7,J9,J11,C16,C18,C20,C22,C24,C26,C28,C30,D35,D37,D39,D41,D43,D45,C49,C51,C53,C56,C58,C60,C62,C68").ClearContents
End With
End Sub

Sub Fermeture()
Dim réponse As Integer
réponse = MsgBox("Do you want to continue? All unsaved data will be lost.", vbQuestion + vbYesNo)
If réponse = vbYes Then
    With Worksheets("Preservation Estimation Tool")
        .Range("C5,C7,C9,E5,E7,E9,E11,J5,J7,J9,J11,C16,C18,C20,C22,C24,C26,C28,C30,D35,D37,D39,D41,D43,D45,C49,C51,C53,C56,C58,C60,C62,C68").ClearContents
    End With
    With Worksheets("Product List")
        .Range("B44:I1040").ClearContents
        .Range("A3:A1040").ClearContents
    End With
    MsgBox "See you soon at Acobal.com!"
    ActiveWorkbook.Close savechanges:=True
Else
  Application.Goto [C53]
End If
End Sub

Sub NouvProj()
Application.Goto Reference:=Worksheets("Preservation Estimation Tool").Range("B3"), Scroll:=True
End Sub
 
Vote positif 0 Vote négatif
Z

Zonmé

XLDnaute Nouveau
Phil69970 à dit:
Bonjour @Zonmé


C'est bien ton exemple mais sur ces 2 lignes on a ceci .... quand j'active les macros

Regarde la pièce jointe 1190321

surement à cause de ce genre de formule fait avec excel 365 et je n'ai que excel 2010

Regarde la pièce jointe 1190322

Je regarde ce que je peux faire sans garantie


***************


Un début de correction
J'ai simplifié le code de la feuille1

Regarde la pièce jointe 1190325
VB: 
Sub MasquerDimensionsAss()
Debut = 33
Fin = 71
ColNb = 1
For i = Debut To Fin
    If Cells(i, ColNb).Value = "" Then
        Cells(i, ColNb).EntireRow.Hidden = True
    Else
        Cells(i, ColNb).EntireRow.Hidden = False
    End If
Next i
Application.Goto [B34], True
End Sub

Sub MasquerProdPres()
Debut = 72
Fin = 93
ColNb = 1
For i = Debut To Fin
    If Cells(i, ColNb).Value = "" Then
        Cells(i, ColNb).EntireRow.Hidden = True
    Else
        Cells(i, ColNb).EntireRow.Hidden = False
    End If
Next i
Application.Goto [B72], True
End Sub

Sub AjouterProduits()
Dim réponse As Integer
réponse = MsgBox("Do you want to continue? All previous data will be saved for final RfQ.", vbQuestion + vbYesNo)
If réponse = vbYes Then
    ActiveSheet.Range("B74:I93").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("C18").Copy
    With Sheets("Product List").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteValues
    End With
    Range("C16,C18,C20,C22,C24,C26,C28,D35,D37,D39,D41,D43,D45,D49,C51,C53,C56,C58,C60,C62").ClearContents
  Else
    Application.Goto [B34]
  End If
  Application.Goto [B15], True
End Sub

Sub NouvelleDemande()
Dim réponse As Integer
réponse = MsgBox("Do you want to continue? All previous data will be deleted.", vbQuestion + vbYesNo)
If réponse = vbYes Then
    With Worksheets("Preservation Estimation Tool")
        .Range("C5,C7,C9,E5,E7,E9,E11,J5,J7,J9,J11,C16,C18,C20,C22,C24,C26,C28,C30,D35,D37,D39,D41,D43,D45,C49,C51,C53,C56,C58,C60,C62,C68").ClearContents
    End With
    With Worksheets("Product List")
        .Range("B44:I1040").ClearContents
        .Range("A3:A1040").ClearContents
    End With
Else
    Application.Goto [B95]
End If
End Sub

Sub AjouterPrinter()
 ActiveSheet.Range("B74:I93").Copy
With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteColumnWidths
    .PasteSpecial Paste:=xlPasteValues
End With
ActiveSheet.Range("C18").Copy
With Sheets("Product List").Range("a" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial Paste:=xlPasteValues
End With
Application.Goto Reference:=Worksheets("My Rfq").Range("B1"), Scroll:=True
End Sub


Et le code de la feuille 9

Regarde la pièce jointe 1190326

VB: 
Sub MasquerRfQPres()
Debut = 1
Fin = 53
ColNb = 1
For i = Debut To Fin
    If Cells(i, ColNb).Value = "" Then
        Cells(i, ColNb).EntireRow.Hidden = True
    Else
        Cells(i, ColNb).EntireRow.Hidden = False
    End If
Next i
ActiveSheet.Range("B1:H53").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveSheet.Range("C54").Value, OpenAfterPublish:=True
Application.Goto [B1], True
End Sub

Sub tt()
With Worksheets("Preservation Estimation Tool")
    .Range("C5,C7,C9,E5,E7,E9,E11,J5,J7,J9,J11,C16,C18,C20,C22,C24,C26,C28,C30,D35,D37,D39,D41,D43,D45,C49,C51,C53,C56,C58,C60,C62,C68").ClearContents
End With
End Sub

Sub Fermeture()
Dim réponse As Integer
réponse = MsgBox("Do you want to continue? All unsaved data will be lost.", vbQuestion + vbYesNo)
If réponse = vbYes Then
    With Worksheets("Preservation Estimation Tool")
        .Range("C5,C7,C9,E5,E7,E9,E11,J5,J7,J9,J11,C16,C18,C20,C22,C24,C26,C28,C30,D35,D37,D39,D41,D43,D45,C49,C51,C53,C56,C58,C60,C62,C68").ClearContents
    End With
    With Worksheets("Product List")
        .Range("B44:I1040").ClearContents
        .Range("A3:A1040").ClearContents
    End With
    MsgBox "See you soon at Acobal.com!"
    ActiveWorkbook.Close savechanges:=True
Else
  Application.Goto [C53]
End If
End Sub

Sub NouvProj()
Application.Goto Reference:=Worksheets("Preservation Estimation Tool").Range("B3"), Scroll:=True
End Sub
Cliquez pour agrandir...
Merci beaucoup @Phil69970 ,
très sympa te ta part. C'est vrai que c'est bien plus clair.
Une question toutefois, j'ai un message pop up en erreur avec la macro "AjouterProduits" en feuille 1 (image en PJ). Pas d'incidence sur le fonctionnement, mais cette alerte apparait. Je l'ai aussi dans le cas ou l'on souhaite enregistré le doc dans la feuille 9, sur la macro "MasquerRfQPres" dans le cas ou a deja un fichier ouvert dans adobe (avec le même nom d'enregistrement). Saurais-tu me dire à quoi cela peut correspondre comme type d'erreur? Je n'ai pas su trouver.
Et quitte à abuser un peu :) , aurais-tu une fonction pour choisir l'emplacement de sauvegarde du fichier PDF générer par la macro en question de la feuille 9 ("MasquerRfQPres"). Pour le nom le format et j'ai su trouver un truc, mais pas pour le choix d'emplacement:
ActiveSheet.Range("B1:H53").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveSheet.Range("C54").Value, OpenAfterPublish:=True
Merci encore
Zonmé
 

Pièces jointes

  • 400.png
    400.png
    7.3 KB · Affichages: 1
Vote positif 0 Vote négatif
Z

Zonmé

XLDnaute Nouveau
Phil69970 à dit:
@Zonmé



1) Le message tu l'avait avant ou tu l'as depuis que tu as recopié mon code de simplification ?

2) Ou veux tu enregistrer le pdf en clair le chemin
Cliquez pour agrandir...
@Phil69970
1): Re. Le message je ne l'avais pas sur cette macro en feuille 1. Après pas vraiment de conséquences sur les calculs et la publications finale.
Et je t'ai dis une bêtise, l'autre message en feuille 9 si un pdf est deja ouvert avec le même nom est completement différent (en PJ).

2): Idéalement j'aimerai que l'utilisateur le choisisse dans une fenêtre, sinon en dossier de téléchargement
 

Pièces jointes

  • erreur feuille 9.png
    erreur feuille 9.png
    15.4 KB · Affichages: 1
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
@Zonmé

Je te propose ce code en remplacement et tu remplaces uniquement cette partie

1707490081109.png


VB: 
Sub AjouterProduits()
Dim Retour As Integer
Retour = MsgBox("Quelle option voulez vous garder ?" & Chr(13) & Chr(10) & _
        "Oui ==> L'option 1" & Chr(13) & Chr(10) & _
        "Non ==> L'option 2" & Chr(13) & Chr(10) & _
        "Annuler ==> On garde les 2", vbYesNoCancel, "Choisir option !")
Select Case Retour
Case 6 'Oui
    ActiveSheet.Range("B74:I77").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("B79:I93").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("C18").Copy
    With Sheets("Product List").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteValues
    End With
    Range("C16,C18,C20,C22,C24,C26,C28,D35,D37,D39,D41,D43,D45,D49,C51,C53,C56,C58,C60,C62").ClearContents
Case 7 'Non
    ActiveSheet.Range("B74:I76").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("B78:I93").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("C18").Copy
    With Sheets("Product List").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteValues
    End With
    Range("C16,C18,C20,C22,C24,C26,C28,D35,D37,D39,D41,D43,D45,D49,C51,C53,C56,C58,C60,C62").ClearContents
Case 2 'Annuler
Retour = MsgBox("Vou pouvez encore choisir de ne rien copier ?" & Chr(13) & Chr(10) & _
        "Ok ==> On copie les 2 options" & Chr(13) & Chr(10) & _
        "Annuler ==> On ne  copie rien et l'oprération est annulée", vbOKCancel, "Annulation ou copier !")
    If Retour = 1 Then ' Ok
        ActiveSheet.Range("B74:I93").Copy
        With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteValues
        End With
        ActiveSheet.Range("C18").Copy
        With Sheets("Product List").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteValues
        End With
        Range("C16,C18,C20,C22,C24,C26,C28,D35,D37,D39,D41,D43,D45,D49,C51,C53,C56,C58,C60,C62").ClearContents
    Else
        [B34].Select
    End If
        [B15].Select
End Select
End Sub

Ce code correspond au bouton ;)
1707490315179.png

Sur le même principe tu peux faire le 2eme bouton si tu n'y arrives pas je le ferais

Je te laisse mettre les messages en anglais sinon tu vas trop rire ..... ! 🤣

Ne pas oublier de faire une copie de sauvegarde avant .....au cas ou....... :rolleyes:
 
Vote positif 0 Vote négatif
Solution
Z

Zonmé

XLDnaute Nouveau
Phil69970 à dit:
@Zonmé

Je te propose ce code en remplacement et tu remplaces uniquement cette partie

Regarde la pièce jointe 1190353

VB: 
Sub AjouterProduits()
Dim Retour As Integer
Retour = MsgBox("Quelle option voulez vous garder ?" & Chr(13) & Chr(10) & _
        "Oui ==> L'option 1" & Chr(13) & Chr(10) & _
        "Non ==> L'option 2" & Chr(13) & Chr(10) & _
        "Annuler ==> On garde les 2", vbYesNoCancel, "Choisir option !")
Select Case Retour
Case 6 'Oui
    ActiveSheet.Range("B74:I77").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("B79:I93").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("C18").Copy
    With Sheets("Product List").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteValues
    End With
    Range("C16,C18,C20,C22,C24,C26,C28,D35,D37,D39,D41,D43,D45,D49,C51,C53,C56,C58,C60,C62").ClearContents
Case 7 'Non
    ActiveSheet.Range("B74:I76").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("B78:I93").Copy
    With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValues
    End With
    ActiveSheet.Range("C18").Copy
    With Sheets("Product List").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteValues
    End With
    Range("C16,C18,C20,C22,C24,C26,C28,D35,D37,D39,D41,D43,D45,D49,C51,C53,C56,C58,C60,C62").ClearContents
Case 2 'Annuler
Retour = MsgBox("Vou pouvez encore choisir de ne rien copier ?" & Chr(13) & Chr(10) & _
        "Ok ==> On copie les 2 options" & Chr(13) & Chr(10) & _
        "Annuler ==> On ne  copie rien et l'oprération est annulée", vbOKCancel, "Annulation ou copier !")
    If Retour = 1 Then ' Ok
        ActiveSheet.Range("B74:I93").Copy
        With Sheets("Product List").Range("B" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteValues
        End With
        ActiveSheet.Range("C18").Copy
        With Sheets("Product List").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial Paste:=xlPasteValues
        End With
        Range("C16,C18,C20,C22,C24,C26,C28,D35,D37,D39,D41,D43,D45,D49,C51,C53,C56,C58,C60,C62").ClearContents
    Else
        [B34].Select
    End If
        [B15].Select
End Select
End Sub

Ce code correspond au bouton ;)
Regarde la pièce jointe 1190354
Sur le même principe tu peux faire le 2eme bouton si tu n'y arrives pas je le ferais

Je te laisse mettre les messages en anglais sinon tu vas trop rire ..... ! 🤣

Ne pas oublier de faire une copie de sauvegarde avant .....au cas ou....... :rolleyes:
Cliquez pour agrandir...
Baah, franchement merci beaucoup Phil. Je vais tester ça l'esprit clair Lundi matin, mais ça à l'air top!
Je te tiens au courant, et encore merci pour ton temps et ta disponibilité, le top du top.
a+++
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
XL 2010 Nature du type de prix de la facture
Réponses
3
Affichages
278
Mody200
M
V
  • Question
Microsoft 365 VBA deux document Excel
Réponses
10
Affichages
451
vroumvroum
V
M
  • Question
XL 2019 étirer liste déroulante
Réponses
10
Affichages
453
milckush
M
E
  • Question
XL 2021 Enlever le bouton (vide) dans un segment
Réponses
0
Affichages
721
Eliot4
E
D
  • Résolu(e)
Microsoft 365 lier deux colonnes selon une liste de distribution dans un premier fichier
2
Réponses
16
Affichages
581
Daniel200666
D
D
  • Question
XL 2019 Bouton VBA
Réponses
3
Affichages
328
sylvanu
sylvanu
Y
  • Question
XL 2013 Reprise d'une colonne dans un TCD
Réponses
4
Affichages
412
Yvan1
Y
B
  • Question
XL 2021 Problème VBA
Réponses
8
Affichages
474
Bensi
B
C
  • Question
Microsoft 365 Problème Code VBA
Réponses
9
Affichages
369
fanch55
fanch55
J
  • Résolu(e)
XL 2021 Aide code VBA - à partir de deux listes, créer une base de donnée
2
Réponses
22
Affichages
885
merinos-BernardEtang
merinos-BernardEtang

Membres actuellement en ligne

9 membres et 88 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 088
Messages
2 116 088
Membres
112 657
dernier inscrit
jpb3