macro pour creer macro

[dmc]

Bonjour à tous les passionnés de ce forum (toujours aussi épatant)
Je cherche à écrire une macro chargée de placer un code tout écrit dans les fichiers qu'elle crée.
Pour Information, ce code est listé ci-après,il est quasiment constant, il fonctionne, mais je ne sais absolument pas comment l'écrire via une autre macro . D'avance je vous remercie de votre aide.

Private Sub Worksheet_Calculate()
Static b As Boolean, I, Compteur As Single, Ligne As Range
    If b = True Then Exit Sub
    'If Target.Count > 1 Or b = True Then Exit Sub
    b = True: Compteur = 0
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        Set Ligne = Cells.Find(what:="Remise sur articles :", After:=Cells(1, 1), LookIn:=xlFormulas, _
        lookat:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False)
    If Not Ligne Is Nothing Then
    On Error GoTo cas_err
        For I = Ligne.Row - 1 To Ligne.Row
        If Cells(I, 5) = 0 Then
            Rows(I).RowHeight = 0
        Else
            Rows(I).EntireRow.AutoFit
            Compteur = Compteur + 1
        End If
        Next I
        If Compteur > 0 Then
            Cells(Ligne.Row + 8, 3) = "les cases grisées indiquent les articles bénéficiant d'une remise individuelle"
            Rows(Ligne.Row + 8).EntireRow.AutoFit
            Rows(Ligne.Row + 3).EntireRow.AutoFit
        Else
            Rows(Ligne.Row + 8).RowHeight = 0
            Rows(Ligne.Row + 3).RowHeight = 0
        End If
        If Compteur > 1 Then Rows(Ligne.Row + 2).EntireRow.AutoFit Else Rows(Ligne.Row + 2).RowHeight = 0
    End If
    If Cells(Ligne.Row + 6, 5) > 0 Then
        Range("A" & Ligne.Row + 7 & ":A" & Ligne.Row + 7).EntireRow.AutoFit
    Else
        Range("A" & Ligne.Row + 7 & ":A" & Ligne.Row + 7).Rows.RowHeight = 0
    End If
    Columns("E:F").EntireColumn.AutoFit
    GoTo finir
cas_err:
    MsgBox ("vous avez saisi une valeur non numérique !")
    Resume Next
finir:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    b = False
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    ' controle des valeurs sur moteurs
Static C As Boolean
If C = True Then Exit Sub
'If Target.Count > 1 Or b = True Then Exit Sub
If Not Intersect(Target, Range("e:e")) Is Nothing Then
    C = True
    If Cells(Target.Row, 1) = "DN" Then
        If Target.Value <> 0 And Target.Value <> 1 Then
            MsgBox (" Saisir 0 ou 1 pour les moteurs")
            Cells(Target.Row, 5) = 0
        End If
    End If
    C = False
End If
End Sub

Amicalement à tous
DMC

 

[mromain]

Re : macro pour creer macro

Bonjour dmc,


La macro suivante crée un nouveau classeur et copie le code contenu dans le module ModuleCodeACopier dans chaque feuille du nouveau classeur créé.

Sub test()
Dim nouveauClasseur As Workbook, vbComp As Object



    'créer un nouveau classeur
    Set nouveauClasseur = Application.Workbooks.Add
    
    'boucler sur chaque module du nouveau classeur (ThisWorkbook + Feuilles + Modules + UserForms + Modules de classe)
    For Each vbComp In nouveauClasseur.VBProject.VBComponents
    
        'si il s'agit d'un module de type Feuille
        If vbComp.Type = 100 And vbComp.Name <> "ThisWorkbook" Then
        
            'copier le code contenu dans le Module "ModuleCodeACopier" de ce classeur
            With ThisWorkbook.VBProject.VBComponents("ModuleCodeACopier").codeModule
                vbComp.codeModule.AddFromString .Lines(1, .CountOfLines)
            End With
        End If
    Next vbComp

End Sub

a+

 

[dmc]

Re : macro pour creer macro

Merci mromain
Vraiment sympathique d'avoir accès à toutes ces compétences doublées de bonne volonté.
Je mets cela en test, et vous informe de ma réussite... dès que je réussis !!!
Amicalement, et avec tous mes remerciements.
DMC

 

[dmc]

Re : macro pour creer macro

Bonne journée Mromain, et aux autres.
J'ai donc essayé cette macro, et un mauvaise surprise m'attendait : alors que tout se déroule normalement, le fichier ainsi créé n'est pas enrichi de la macro. Je précise que j'ai pisté le déroulement, et qu'ainsi au moment de l'enregistement de ce fichier, je vois dans l'explorateur que la feuille est enrichie. mais lorsque je la réouvre, rien, nada, que tchi, .
Bref je suis bloqué. Ci dessous l'extrait de code modifié par mes soins, si jamais vous avez une idée, un conseil, un indice, de la sympathie, de la pitié..... Amicalement DMC
PS : j'ai laissé dans cet extrait l'intégralité des lignes de code entre l'insertion de macro et la sauvegarde du fichier, des fois que l'une de ces lignes ....?

    ' insertion des macros
    'Dim nouveauClasseur As Workbook, vbComp As Object
    'créer un nouveau classeur
    'Set nouveauClasseur = Application.Workbooks.Add
    'boucler sur chaque module du nouveau classeur (ThisWorkbook + Feuilles + Modules + UserForms + Modules de classe)
    For Each vbComp In Workbooks(File_Is).VBProject.VBComponents
        'si il s'agit d'un module de type Feuille
        zz = vbComp.Name
        'zzz = CodeNouvFeuille
        If vbComp.Type = 100 And vbComp.Name = CodeNouvFeuille Then
            'copier le code contenu dans le Module "Module2" de ce classeur
            With Workbooks(ma_macro_is).VBProject.VBComponents("Module2").codeModule
                vbComp.codeModule.AddFromString .Lines(1, .CountOfLines)
            End With
        End If
    Next vbComp

    Range("A1").Activate
    ' déco haut du sous-total haut
   If ligne_finitions > 0 Then
        deblig = 1
        finlig = ligne_finitions - 1
        GoSub colTsMonts
        deblig = ligne_finitions
        If ligne_selleries > ligne_finitions Then finlig = ligne_selleries - 1 Else finlig = Ligne - 1
        GoSub colTsMonts
    End If
    If ligne_selleries > 0 Then
        If ligne_finitions > 0 Then deblig = ligne_finitions Else deblig = 1
        finlig = ligne_selleries - 1
        GoSub colTsMonts
        deblig = ligne_selleries
        finlig = Ligne - 1
        GoSub colTsMonts
    End If
    If ligne_selleries <= 0 And ligne_finitions <= 0 Then
        deblig = 1: finlig = Ligne - 1: GoSub colTsMonts
    End If
    ' déco bas du sous-total haut
    ' insertion des options supplémentaires du bas
    deblig = Ligne: finlig = Lignefin: GoSub colTsMonts
    ' application du contour
        Set trouve = Range("A1:F" & Lignefin + 10)
        GoSub contour
        Set trouve = Range("A2:F" & Lignefin + 10)
        GoSub contour
    For I = 3 To Lignefin       ' coloriage sous-titres
        If Range("H" & I).Text = "titre" Then
            With Range("C" & I)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                With .Font
                    .Name = "Gill Sans MT"
                    .FontStyle = "Gras"
                    .Size = 12
                    .ColorIndex = 5
                    On Error Resume Next
                    .ThemeColor = colorfond
                    .TintAndShade = 0
                    On Error GoTo 0
                End With
                On Error Resume Next
                With .Interior
                        .ThemeColor = colorfond
                        .TintAndShade = 0.799981688894314
                        .PatternTintAndShade = 0
                End With
                On Error GoTo 0
            End With
        End If
    Next I
    'réalignement colonnes et lignes
    'suppression lignes parasites
    With Range(Cells(1, 7), Cells(1, 7).End(xlDown).End(xlToRight))
        .Borders.LineStyle = xlNone
        .Delete
    End With
    With Range(Cells(Lignefin + 11, 1), Cells(Lignefin + 11, 1).End(xlDown).End(xlToRight))
        .Borders.LineStyle = xlNone
        .Delete
    End With
    ActiveWindow.ScrollRow = 1  'place la ligne 1 en haut de l'écran
    ActiveWindow.View = xlNormalView 'place affichage en mode normal
    Columns("A:B").WrapText = False
    Columns("A:B").EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit 'ajuste les colonnes à la meilleure taille
    Columns("C:C").ColumnWidth = 255
    Cells.EntireRow.AutoFit
    Columns("C:C").ColumnWidth = 105
    Cells.EntireRow.AutoFit
    Columns("A:B").EntireColumn.AutoFit
    Columns("D:F").EntireColumn.AutoFit
    Columns("A:B").EntireColumn.AutoFit
    Columns("D:F").EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
    'placement du logo jeanneau
    indpr = 0
    If InStr(1, modele, "PRESTIGE", vbTextCompare) > 0 Then
        indpr = 1
        With ActiveSheet.Pictures.Insert(mon_Emplace & "Logo_prestige.bmp").ShapeRange
            .LockAspectRatio = msoTrue
            .Height = 30
            .Left = 1
            .Top = 1
            .PictureFormat.TransparentBackground = msoTrue
            .PictureFormat.TransparencyColor = RGB(255, 255, 255)
            .Fill.Visible = msoFalse
        End With
    Else
        With ActiveSheet.Pictures.Insert(mon_Emplace & "Logo Jeanneau horizontal 2010.jpg").ShapeRange
            .LockAspectRatio = msoTrue
            .Height = 30
            .Left = 1
            .Top = 1
            .PictureFormat.TransparentBackground = msoTrue
            .PictureFormat.TransparencyColor = RGB(255, 255, 255)
            .Fill.Visible = msoFalse
        End With
    End If
        'placement du logo delpeyrat
    With ActiveSheet.Pictures.Insert(mon_Emplace & mon_logo).ShapeRange
        .LockAspectRatio = msoTrue
        If indpr = 1 Then
            .Height = 18 + wybH
            .Left = 125 + wybL
            .Top = 6 - wybT
        Else
            .Height = 18 + wybH
            .Left = 60 + wybL
            .Top = 7 - wybT
        End If
        .PictureFormat.TransparentBackground = msoTrue
        .PictureFormat.TransparencyColor = RGB(255, 255, 255)
        .Fill.Visible = msoFalse
    End With
        'placement du commentaire éventuel
    If memo_comm <> "" Then
        With Range("A" & Lignefin + 1)
            If .Comment Is Nothing Then .AddComment
            .Comment.Visible = True
            .Comment.Text WorksheetFunction.Trim(memo_comm)
            memo_comm = ""
            .Comment.Shape.Left = .Left + 50
            .Comment.Shape.Top = .Top + 10
            .Comment.Shape.Height = 12 * (NBcomm + 1)
            .Comment.Shape.Width = 300
            '.Comment.Shape.Connector = False
        End With
    End If
    indpr = 0
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Columns("C:C").ColumnWidth = 255
    Cells.EntireRow.AutoFit
    Columns("C:C").ColumnWidth = 105
    Cells.EntireRow.AutoFit
    'mise en page
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ActiveSheet.PageSetup.PrintArea = "" 'annulation zone d'impression
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = "&""Arial,Gras""Tarif catalogue " & tarif & " Jeanneau " & modele & " et Options"
        .RightHeader = ""
        .LeftFooter = "&""Arial,Gras" & """" & monnom & Chr(10) & montel & ""
        .CenterFooter = "Tarif " & tarif
        .RightFooter = "édité le &D   Page &P/&N"
        .LeftMargin = Application.InchesToPoints(0.3)
        .RightMargin = Application.InchesToPoints(0.3)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .HeaderMargin = Application.InchesToPoints(0.2)
        .FooterMargin = Application.InchesToPoints(0.2)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    'lignes figées et élargissement taille écran
    Columns("A:F").Select   'colonnes à afficher sur largeur d'écran
    ActiveWindow.DisplayHeadings = True ' affichage entetes de colonnes et de lignes
    ActiveWindow.WindowState = xlNormal
    ActiveWindow.Top = 1
    ActiveWindow.Left = 1
    ActiveWindow.Width = 800
    ActiveWindow.Height = Application.UsableHeight
    Columns("E:E").EntireColumn.AutoFit
    Columns("F:F").EntireColumn.AutoFit
    ActiveWindow.Zoom = True    ' application largeur d'écran
    ActiveWindow.Width = Application.UsableWidth
    If Len(modele) > 0 Then ActiveSheet.Name = compl_Nom & modele
    Range("A2").Activate 'positionne le curseur sur la première ligne de choix, en vue de lignes figées
    ActiveWindow.FreezePanes = True  'lignes figées
    Columns("F:F").EntireColumn.AutoFit
    Union(Range("A" & Lignefin + 2 & ":A" & Lignefin + 6), Range("A" & Lignefin + 9 & ":A" & Lignefin + 10)).Rows.RowHeight = 0
    Range("E2").Select
    Sheets(1).Activate
    Sheets(1).Range("E2").Select 'positionne le curseur sur la première ligne de choix, en vue de l'enregistrement
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=repert_Is & "traités\" & wybou _
        & compl_Nom & Replace(File_Is, ".xls*", "") _
        , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    Application.DisplayAlerts = True
fin_modele:
        mont_transport = 0: swap_Suzuki = 0
    ActiveWorkbook.Close
    File_Is = Dir
    'Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Loop

 

[Gourou AWK]

Re : macro pour creer macro

Une piste ???

De mémoire, il faut explicitement enregistrer le classeur dans lequel on ajoute le code; il y avait une anomalie dans Excel qui ne considérait pas dans ce cas que le classeur avait été modifié..

 

[mromain]

Re : macro pour creer macro

Bonjour dmc, Gourou AWK , le forum


A part la piste évoquée par notre Gourou, je ne vois pas trop. essaye avec ce code :

    'boucler sur chaque module du nouveau classeur (ThisWorkbook + Feuilles + Modules + UserForms + Modules de classe)
    For Each vbComp In Workbooks(File_Is).VBProject.VBComponents
        'si il s'agit d'un module de type Feuille
        zz = vbComp.Name
        'zzz = CodeNouvFeuille
        If vbComp.Type = 100 And vbComp.Name = CodeNouvFeuille Then
            'copier le code contenu dans le Module "Module2" de ce classeur
            With Workbooks(ma_macro_is).VBProject.VBComponents("Module2").codeModule
                vbComp.codeModule.AddFromString .Lines(1, .CountOfLines)
            End With
        End If
    Next vbComp

'    'enregistrer pour la première fois le nouvau classeur (au format xlsm)
'    Workbooks(File_Is).SaveAs "C:\nouveauClasseur", xlOpenXMLWorkbookMacroEnabled
    'enregistrer les modifications apportées au nouveau classur (déjà enregistré)
    Workbooks(File_Is).Save

a+

 

[dmc]

Re : macro pour creer macro

Ok je teste.
En tout cas merci à tous, ça je n'aurais jamais pu trouver sans vous.
Je vous tiens informés du résultat.
DMC

 

[dmc]

Re : macro pour creer macro

Bonsoir (d'outre-tombe) à Mromain, Gourou, et à tous les xldnautes de bonne volonté.
Je désespère : 3 jours que je bloque sur ce complément d'une grosse macro, complément consistant à enrichir via cette macro d'autres fichiers, identiques en structure et nombreux, à les enrichir donc d'automatismes de controles.
J'ai fini par mettre au point une méthode, que je joins, et qui semble fonctionner sur l'exemple mis en place.
Mais pas sur ma grosse macro !
Aussi, je vous demande de bien vouloir tester sur vos ordi ces deux petits fichiers que je vous joins, sans virus à ma connaissance.
Merci de m'indiquer si cela marche sans problème chez vous, et également si vous avez un complément qui expliquerait que dans ma grosse macro je ne retrouve pas sur le fichier cible les lignes crées alors même qu'elles sont présentes au moment de l'enregistrement de ce fichier cible.
OUF,pas simple de s'expliquer, surtout quand on déprime.
Alors je compte sur vous, comme d'habitude.
Amicalement - DMC

 

[dmc]

Re : macro pour creer macro

Bonjour à tous, Mromain, le Gourou ...
J'ai réussi à faire fonctionner mon ensemble, aussi je vous joins le script qui fonctionne, cela peut en dépanner à l'occasion :

 Private Function macro_insert(ma_place As String, File_Is As String)

' Macro enregistrée au départ le 17/09/2006 par David Massé
Dim ma_macro_is As String
Dim vbComp As Object
Dim i As Single
    ma_macro_is = ThisWorkbook.Name
    Workbooks.Open Filename:=ma_place & File_Is
    Sheets(1).Activate
    ' insertion des macros
    'boucler sur chaque module du nouveau classeur (ThisWorkbook + Feuilles + Modules + UserForms + Modules de classe)
    For Each vbComp In Workbooks(File_Is).VBProject.VBComponents
        'si il s'agit d'un module de type Feuille
        If vbComp.Type = 100 Then                   'And vbComp.Name = CodeNouvFeuille
            'copier le code contenu dans le Module "Module2" de ce classeur
            With Workbooks(ma_macro_is).VBProject.VBComponents("Module2").codemodule
                If vbComp.codemodule.CountOfLines > 0 Then 'enlever le code déjà existant
                    vbComp.codemodule.DeleteLines 1, vbComp.codemodule.CountOfLines
                End If
                vbComp.codemodule.AddFromString .Lines(1, .CountOfLines)
            End With
        End If
        ' faire pareil pour un module, et non pas une feuille, en créant ce module à partir de module3
            ' copier le code contenu dans le Module "Module3" de ce classeur
'            With Workbooks(ma_macro_is).VBProject.VBComponents("Module3").codemodule
'                If Workbooks(File_Is).VBProject.VBComponents.codemodule.CountOfLines > 0 Then 'enlever le code déjà existant
'                    Workbooks(File_Is).VBProject.VBComponents.codemodule.DeleteLines 1, vbComp.codemodule.CountOfLines
'                End If
'                Workbooks(File_Is).VBProject.VBComponents.codemodule.AddFromString .Lines(1, .CountOfLines)
'            End With
    Next vbComp
    Workbooks(File_Is).SaveAs ma_place & Left(File_Is, InStr(1, File_Is, ".xls") - 1) & ".xls", xlNormal
    ActiveWorkbook.Close
 End Function

Par contre, je n'ai pas trouvé comment faire la même chose, mais non plus sur des feuilles, mais sur un module.
C'est pourquoi ces lignes sont en REM
J'ai beau faire, je ne sais pas :
- repérer l'endroit ( module) où écrire
- le créer
- le remplir

Dois-je pour ce sujet ouvrir un nouveau fil ?

Dans l'attente de vos réponses, et vous en remerciant par avance.

DMC

 

[James007]

Re : macro pour creer macro

Bonjour dmc,

A ma connaissance, avec VBE, si je me souviens bien, il n'existe pas de manière directe de copier un module d'un projet à un autre ...

Pour arriver à tes fins, tu dois d'abord exporter le module de ton projet source et ensuite importer ce même module dans ton projet destination ...

Si je retrouve ce code dans mes archives, je te poste ...

A +

 

[dmc]

Re : macro pour creer macro

Bonjour James007.
Bond....iou de Bondiou !!!
Toujours bonD de voir quelqu'un s'intéresser à mon problème.
Pour te répondre :
Le code que j'exploite déjà sait compléter le script des différentes feuilles de mes fichiers cibles. Mais il travaille sur Workbooks(File_Is).VBProject.VBComponents.Type =100,
et pour les modules je crois avoir compris qu'il s'agit du type 1. C'est là que je sèche, car dans mes classeurs, il n'y a pas encore de module (type 1 ) donc pas moyen de les corriger, il faut les créer, et re-là je sèche.
Par contre, je pense qu'une fois créé,le module sera aisément rempli par la ligne :
Workbooks(File_Is).VBProject.VBComponents.codemodule.AddFromString .Lines(1, .CountOfLines)
Qu'en penses-tu ?
à lire vos réponses à tous, merci d'avance.

 

[James007]

Re : macro pour creer macro

Re,

Je vais essayer de regarder plus en détail ...

Mais avant toute chose, quelle est la version que tu utilises de VBE, car cela risque bien d'avoir son importance ...

A +

 

[James007]

Re : macro pour creer macro

Re,

Effectivement, le type pour les modules est 1 ...

Je viens de trouver un lien en anglais ( j'espère que çà va ...) qui pourrait t'aider ...

A +

 

[tototiti2008]

Re : macro pour creer macro

Bonjour dmc, Bonjour James

peut-être par là :

Visual Basic Editor

 

[James007]

Re : macro pour creer macro

Salut tototiti2008 ...

Excellent lien ... bien meilleure source ...

Milles Mercis ... je m'y plonge aussi !!!

A +