Transfert de Macro d'un classeur A vers classeur B / Fonction .Copy

Bonjour à tous,

J'ai un classeur source A sur lequel j'ai créé trois modules reliés à trois boutons

1. Première macro (boucle) :
   1. Selectionne les feuilles de calculs
   2. Copie ces feuilles dans un nouveau classeur B1
   3. Envoi le classeur B1 a l'adresse email lié au destinataire D1 de B1
   4. Boucle continue jusqu'a ce que tous les emails soient envoyes aux differents destinataires B2, B3 etc...
2. Deuxieme Macro :
1. Doit s'executer sur le classeur B1
2. Copie et renomme le classeur B1 en un classeur C1
3. Classeur C1 est renvoye a l'emetteur du classeur A via Outlook
3. Troisieme Macro :
   1. Envoi un accuse de reception a l'emetteur du classeur C1

La premiere macro marche nickel car executee depuis le meme classeur.

Mon probleme est que lorsque le destinataire recoit le classeur B1 et qu'il clique sur le bouton de la seconde macro elle ne peut s'executer car elle est liee au classeur A dont il n'est pas en possession.

Mon objectif : lorsque le classeur A est copie et envoye sous classeur B les macros doivent etre transferees/copiees sur le classeur B et non etre liees au classeur A.

J'ai cherché mais je n'ai pas trouvé de solution pour que mes trois macros/modules soient transférées de fichier en fichier telle que initialement codee sur le classeur A.

Merci pour votre aide.

Jeremy

Bonjour Jeremy et bienvenu, bonjour le forum,

ils sont où les fichiers ou au pire les macros ? SI tu as un problème avec ta voiture, tu vas chez le garagiste en vélo et tu lui expliques ?

Hello,

Thauthème .

Moi je ferai une copie de ton classeur A avec les macros dedans mais sans données dans les feuilles du classeur (classeur model)

Je viendrai copier les feuilles dans ce classeur et j'enverrai ce classeur. Comme ça le destinataire pourrait utiliser les macros.

R@g

Bonjour,

voici une solution de recopie de macros de la feuille active ...

bonjour ThauThème & Rag

en attendant la voiture j'ai fourni la caisse à outils !

pas pour vous contredire bien au contraire mais j'étais en train de travailler dessus depuis 1/4 d'heure

Bonjour le fil, bonjour le forum,

Je ne comprends pas, quand on fait la copie d'un fichier au format xlsm, les macros sont conservées dans cette copie. Si on avait le code, on pourrait faire en sorte que les noms des classeurs dans ce code soit remplacés par des variables qui s'adapteraient avec le nouveau nom. Non ?...

Tout a fait d'accord

Re-

ThauThème a écrit :

Bonjour le fil, bonjour le forum,

Je ne comprends pas, quand on fait la copie d'un fichier au format xlsm, les macro sont conservées dans cette copie. Si on avait le code, on pourrait faire en sorte que les noms des classeurs dans ce code soit remplacés par des variables qui s'adapteraient avec le nouveau nom. Non ?...

en l'occurrence, dans un tel code, on pourrait alors choisir de ne transférer qu'une partie des macros.

On peut vouloir dispatcher un fichier par vendeur par exemple avec une aide à la saisie des infos, et garder en central certaines fonctions. Mais oui, c'est sans doute assez marginal.

On verra quand le carrosse entrera au garage de quoi il s'agit !

Hello messieurs,

Desole pour le delai je suis en plein rush de fin d'annee.

Merci tout d'abord pour vos premiers retours. En effet avec le fichier ce sera mieux peut etre.

Le but du fichier est de lancer un appel d'offres a differents fournisseurs (liste sur la feuille de calcul "Vendors List").

Sur la premiere feuille de calcul du fichier "Tender Data Sheet- No Pwd.xlsm - Fichier Initial" j'ai ajoute 3 boutons en base du tableau :

• Send to Bidders => copie en selectionnant uniquement certains feuilles et nouveau fichier sous nouveau nom est envoye a chaque fournisseur susceptible de participer a l'appel d'offre (le fournisseur recoit le fichier "xxx - Trucking Tender 2021 - BBB Group - 11-18-2020.xlsm - Fichier Intermediaire")
• Send to xxx ==> un fois le fichier "xxx - Trucking Tender 2021 - BBB Group - 11-18-2020.xlsm" rempli, le fournisseur clique sur ce bouton et cela renvoit un email a ma societe avec le fichier "- Empty Trucking Tender Submission - 11-18-2020.xlsm - Fichier Final"
• Receipt to Bidder ==> une fois que les equipes de ma societe on verifie que toutes les informmations sont bonnes elles renvoient un accuse reception.

Mon probleme c'est les macros du FIchier initial ne sont pas transferees sur le fichier intermediaire puis final.

Du coup lorsque le fournisseur recoit son fichier intermediaire qu'il le complete et veut activer l'envoi automatique du fichier vers notre societe ca ne fonctionne pas car il ne possede pas le fichier initial.

Les boutons etant assignes aux macros du fichier initial.

En esperant que vous puissiez m'aider car je n'ai toujours pas trouve sur ce forum ou sur le net.

Bonne journee

Jeremy

@jeremy ... as-tu essayé la caisse à outil donnée ci-avant ?

Bonjour Steelson,

Je ne suis pas sur de savoir comment ca marche.

1. J'ai essayé sur ton fichier directement. Lorsque je clique sur "dupliquer" via ton fichier ca ouvert un autre classeur pour lequel je ne vois pas le ModuleRecopie sur le nouveau fichier mais peut etre c'etait pour implementer cette partie de code sur mon module 1 du fichier initial qui va etre replique
2. J'ai donc essaye mais je ne sais pas trop ou integrer ces parties de code sur le mien. Ou quels sont les items a modifier en fonction de mon fichier. Ci dessous mon essai mais j'obtiens :

Option Explicit
Sub Bulkemails()
  Dim OutApp As Outlook.Application
  Dim OutMail As Outlook.MailItem
  Dim OutAccount As Outlook.Account
  Dim DestWbk As Workbook, SourceWbk As Workbook, Sht As Worksheet
  Dim sPath, sFilename, sName1, sName2, sDate, Sbody, Signature, SigString As String
  Dim Col As Long, Lig As Long, lstRow, lstCol As Long
  Dim sendTo As String
  Dim TheActiveWindow As Window
  Dim TempWindow As Window
  Dim myMacro As VBComponent

Set myMacro = ActiveWorkbook.VBProject.VBComponents(WsCodeName(ActiveSheet))
Workbooks.Add
RecopierMacro myMacro, ActiveWorkbook.VBProject.VBComponents(WsCodeName(ActiveSheet))

'INITIALIZATION OF VARIABLES
Set SourceWbk = ActiveWorkbook

    'Copy the sheets to a new workbook
    'We add a temporary Window to avoid the Copy problem
    'if there is a List or Table in one of the sheets and
    'if the sheets are grouped

With SourceWbk
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("Cover", "Tender Specifications", "Trucking SLA", "1. Company Identity Card", "2 Your Svc Commitment", "3. Quotation_Empty truck", "4. Contact_Matrix", "xxx Volumes 2020", "List")).Copy
End With

    'Close temporary Window
TempWindow.Close

Set DestWbk = ActiveWorkbook

Set Sht = Worksheets("Cover")

With Sht
     sName1 = .Range("B1").Value
End With

ThisWorkbook.Sheets("Vendors List").Activate
'Getting last row of containing email id in column 4.
  lstRow = Cells(Rows.Count, 5).End(xlUp).Row
  lstCol = Cells(4, Columns.Count).End(xlToLeft).Column

For Lig = 5 To lstRow
    For Col = 4 To lstCol Step 2
      ' Adresse mail du destinataire
      sendTo = Cells(Lig, Col).Value
      If sendTo = "" Then GoTo SuiteCol
      sName2 = Cells(Lig, Col - 1).Value
      sDate = Format(Now, "mm-dd-yyyy")
      sPath = "V:\Procurement\2021\Trucking\TDSSent\"
      sFilename = sPath & sName1 & " - " & sName2 & " - " & sDate & ".xlsm"

Sbody = "<font face=""calibri"" style=""font-size:11pt;"">Dear Potential Bidder," & _
    "<br><br>" & _
    " Your organisation along with others is invited to offer a tender for provision of the above, to the specification outlined in the attached document :" & _
    "<br><br>" & _
    "Document 1 : Cover" & _
    "<br>" & _
    "Document 2 : Trucking SLA" & _
     "<br>" & _
    "Document 3 : Company Identity Card" & _
     "<br>" & _
    "Document 4 : Your Svc Commitment" & _
     "<br>" & _
    "Document 5 : Quotation Empty Truck" & _
     "<br>" & _
    "Document 6 : Contact Matrix" & _
     "<br>" & _
    "Document 7 : xxx Volumes 2020" & _
     "<br>" & _
    "Document 8 : Service Standard" & _
    "<br><br>" & _
    "Please read the instructions on the tendering procedures carefully. Failure to comply with them may invalidate your tender which must be returned by the date and time given below." & _
    "<br><br>" & _
    "An electronic copy of your tender must be received by" & " " & Sht.Range("C78") & " " & "no later than" & " " & Sht.Range("C77") & " " & "at 12 noon. Late tenders will not be considered." & _
    "<br><br>" & _
     "We look forward to your response," & "</font>"

'------------------------------------------------------------------------------------
'SAVE AS XLSM FILE
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\TenderProcess.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

On Error Resume Next
  DestWbk.Copy
  DestWbk.SaveAs filename:=sFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled

'CREATE OUTLOOK EMAIL
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
    Set OutAccount = OutApp.Session.Accounts("xxx-tender.process@xxx.com")
With OutMail
    .Display
    .To = sendTo
    .CC = "xxx-tender.process@xxx.com"
    .Subject = " xxxx - Invitation To Tender - Empty Trucking Activities" & " - " & sDate
    .HTMLBody = Sbody & "<br>" & Signature
    .Attachments.Add sFilename
    .SendUsingAccount = OutAccount
    .Send
End With

SuiteCol:
    Next Col
  Next Lig

TheEnd:
Set Sht = Nothing: Set DestWbk = Nothing: Set SourceWbk = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Set OutAccount = Nothing

With Application
        .ScreenUpdating = True
        .EnableEvents = True
End With

End Sub

Sub RecopierMacro(depuis As VBComponent, jusque As VBComponent)
        With jusque.CodeModule
        For i = 1 To depuis.CodeModule.CountOfLines
            .InsertLines i, depuis.CodeModule.Lines(i, 1)
        Next
    End With
End Sub
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Function WsCodeName$(Ws As Object)
On Error Resume Next
With Application.VBE.MainWindow
     WsCodeName = Ws.CodeName
End With
End Function

Justement, le seul module à ne pas recopier est le module qui fait la recopie ! A moins qu'il faille aussi que le destinataire ait cette possibilité ? dans ce cas il faudra aussi lui demander de modifier ses paramètres de sécurité.

Je vais regarder ton fichier cet soir.

By the way ...

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

et

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

je n'ai jamais réussi à faire fonctionner de façon stable, et il y a beaucoup beaucoup plus simple :

            .HTMLBody = Sbody & "<br>" & .HTMLBody

Voici le module de recopie

Il faudra cocher la réference Microsoft Visual Basic for Applications Extensibility 5.3

correction ci-dessous pour ne dupliquer que les modules

je ne peux pas aller plus loin

Je vais regarder avec ce que tu m'as donné. Merci.

Le MDP : uV23@TXY&p20

merci

ne pas oublier de donner les clés de la voiture quand on la met au garage

juste un petit soucis, c'"est qu'il recopie des modules vides provenant des feuilles, donc petite correction qui fonctionne bien sur ton fichier

Sub dupliquer()
' cocher la réference Microsoft Visual Basic for Applications Extensibility 5.3
Dim Wb1 As Workbook, vbCmp1 As Object
Dim Wb2 As Workbook, vbCmp2 As Object
Set Wb1 = ThisWorkbook
Set Wb2 = Workbooks.Add

' faut-il oui ou non rcopier toutes les feuilles ?
Wb1.Sheets(1).Cells.Copy Destination:=Wb2.Sheets(1).Cells(1, 1)

' faut-il oui ou non recopier le ModuleRecopie"
For Each vbCmp1 In Wb1.VBProject.VBComponents
    If vbCmp1.Name <> "ModuleRecopie" Then
        If vbCmp1.Type = 1 Then
            Set vbCmp2 = Wb2.VBProject.VBComponents.Add(1)
            RecopierMacro vbCmp1, vbCmp2
        End If
    End If
Next

End Sub

Sub RecopierMacro(de As Object, vers As Object)
Dim i
    With vers.CodeModule
        For i = 1 To de.CodeModule.CountOfLines
            .InsertLines i, de.CodeModule.Lines(i, 1)
        Next
    End With
End Sub

je n'i traité que l'aspect macro comme demandé, ne pas oublier d'aménager le code pour copier toutes les feuilles si nécessaires, les boutons d'action et le modulederecopie si nécessaire pour la personne suivante