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

 

[kjin]

Re : macro pour creer macro

Bonsoir,
Un fil qui peut peut-être t'inspirer
ICI
A+
kjin

 

[dmc]

Re : macro pour creer macro

Bonjour à tous, James007, tototiti2008, Mromain, le Gourou....
Juste pour dire, comme James007, que ce lien est formidable : clair, simple, complet.
Je présente ci-après une solution complète, qui enrichit aussi bien les feuilles que les modules de fichiers existants. Vous remerciant tous de m'avoir si bien aidé.

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

Dim ma_macro_is As String
Dim VBComp As Object
Dim wBComp As Object
Dim X As Integer
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
Select Case VBComp.Type
Case 1 ' vbext_ct_StdModule ' 1
' I = VBComp.CodeModule.CountOfDeclarationLines + 1
X = VBComp.CodeModule.CountOfLines
If X > 0 Then Workbooks(File_Is).VBProject.VBComponents.Remove VBComp
Case 100 'vbext_ct_Document ' 100 (And vbComp.Name = CodeNouvFeuille)
'si il s'agit d'un module de type Feuille
'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 Select
Next VBComp
'Ajoute un module standard dans le classeur
Set wBComp = Workbooks(File_Is).VBProject.VBComponents.Add(1)
'Renomme le module
'wBComp.Name = "ModuleFonctions"
With Workbooks(ma_macro_is).VBProject.VBComponents("Module3").CodeModule
wBComp.CodeModule.AddFromString .Lines(1, .CountOfLines)
End With
Workbooks(File_Is).SaveAs ma_place & Left(File_Is, InStr(1, File_Is, ".xls") - 1) & ".xls", xlNormal
ActiveWorkbook.Close
End Function

 

[James007]

Re : macro pour creer macro

Bonjour dmc,

Merci à toi de partager avec le Forum ... la solution complète ...

Félicitations pour ton travail

A +

 

[mromain]

Re : macro pour creer macro

Bonjour dmc, James007, tototiti2008, kjin, Gourou, le forum,


Désolé de t'avoir laissé en plan dmc. Je n'avais pas trop de temps dernièrement.
Je vois que tu as pu résoudre ton problème ; et comme l'a signalé James007 : merci d'avoir partagé ta solution .

a+

 

[kjin]

Re : macro pour creer macro

Bonsoir,

Je présente ci-après une solution complète, qui enrichit aussi bien les feuilles que les modules de fichiers existants

Il faudrait juste nous expliquer un peu cette fonction, parce que là j'y perds un peu mon latin...!
Et pour finir

Workbooks(File_Is).SaveAs ma_place & Left(File_Is, InStr(1, File_Is, ".xls") - 1) & ".xls", xlNormal

A+
kjin

 

[dmc]

Re : macro pour creer macro

Bonjour KJIN, merci à Mromain et James, donner ma solution était la moindre des choses,lorsque l'on sollicite vos compétences et votre bonne volonté, il est élémentaire de tenter d'apporter son tout petit caillou à l'édifice.
Pour répondre à KJIN, je pense à l'examen de cette ligne que je ne suis pas allé au bout de mon raisonnement, ce qui rend le INSTR inutile. Mon objectif était de placer le bon suffixe XLS, même partant d'un fichier xlsx ou xlsm etc...Sans doute faut-il compléter d'une étoile :
Workbooks(File_Is).SaveAs ma_place & Left(File_Is, InStr(1, File_Is, ".xls*") - 1) & ".xls", xlNormal
Je n'ai pas encore testé, et je ne suis pas à mon aise avec les différentes versions d'Excel, en terme de suffixes et de compatibilités descendantes.
Merci de m'avoir signalé cette coquille, bévue, lacune, ...
Amicalement à tous

 

[dmc]

Re : macro pour creer macro

Bonsoir KJIN et les autres.
Je reviens sur ce test de l'étoile qui me restait à faire. Ma réponse était fausse, elle venait du fait que auparavant j'étais passé par un replace plutôt qu'un instr, et je croyais encore en être à ce stade.
En fait aujourd'hui, je tiens à avoir dans tous les cas un suffixe xls en sortie, même si en entrée certains fichiers de type xlsm ou autres xls peuvent se présenter.
De cette façon, je suis sûr (sauf à me prouver le contraire) que j'aurai bien un xls en sortie.
Amitiés