[XL-2003] Affectation de macro a des boutons dynamiques

neninio31 · 02/07/2009, 15h43

RE

Voila mon autre problème

j'ai réussi a créer des boutons dynamiques avec macro associée a l'activation d'une feuille ça ça marche bien avec le code suivant

Code :

Dim line As Long
line = Sheets("BD").Range("M2") + 1
Dim Obj As OLEObject
Dim laMacro As String
Dim x As Integer
Dim i As Integer
Dim n  As Long
n = Sheets("BD").Range("Z2").Value - 1
 
 
 
 
For i = 0 To n
 
Set Obj = ActiveSheet.OLEObjects.Add("Forms.CommandButton.1")
With Obj
   .Name = "VOIR" & i 'renomme le bouton
    .left = 800 'position horizontale par rapport au bord gauche de la feuille
    .top = 200 + i * 35 'position verticale par rapport au bord haut de la feuille
    .width = 45 'largeur
    .height = 25 'hauteur
    .Object.Caption = "VOIR"
    .PrintObject = False
End With
 
 
 
 
 
 
laMacro = laMacro & "Sub VOIR" & i & "_Click()" & vbCrLf
laMacro = laMacro & "Sheets(""SELRESULT"").Unprotect" & vbCrLf
laMacro = laMacro & "Sheets(""BD"").Range(""O2:Y2"").ClearContents" & vbCrLf
laMacro = laMacro & "Sheets(""BD"").Range(""Q2"")=Sheets(""SELRESULT"").Range(""C" & i + 4 & """).Value" & vbCrLf
laMacro = laMacro & "Sheets(""BD"").Range(""A1:K" & line & """).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets(""BD"").Range(""O1:Y2""), CopyToRange:=Sheets(""SELRESULT"").Range(""A" & n + 5 & """), Unique:=False" & vbCrLf
laMacro = laMacro & " With Range(""A" & n + 5 & ":K" & n + 6 & """).Font" & vbCrLf
laMacro = laMacro & "  .ColorIndex = 2 " & vbCrLf
laMacro = laMacro & "End With " & vbCrLf
laMacro = laMacro & "UserForm2.Show" & vbCrLf
laMacro = laMacro & "End Sub" & vbCrLf
 
Next i
 
 
With ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
    x = .CountOfLines + 1
    .InsertLines x, laMacro
 
End With
 
End If
 
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
ActiveSheet.EnableSelection = xlNoSelection
 
 
End Sub

Seulement lors d'un rafraichissement j'ai besoin de supprimer ces bouton et leur macro (ça j'arrive aussi a le faire !) pour créer une nouvelle série de bouton avec leur macro associées.

Alors les boutons s'affichent les macros s'ecrivent mais on dirait que l'affectation ne s'est pas faite car un click sur les boutons ne donne rien

voici le code

Code :

For i = 0 To n - 2
 
 
           Set Obj = ActiveSheet.OLEObjects.Add("Forms.CommandButton.1")
            With Obj
               .Name = "VOIR" & i 'renomme le bouton
                .left = 800 'position horizontale par rapport au bord gauche de la feuille
            .top = 200 + i * 35 'position verticale par rapport au bord haut de la feuille
                .width = 45 'largeur
                .height = 25 'hauteur
                .Object.Caption = "VOIR"
                .PrintObject = False
            End With
 
 
 
 
 
                'Spécifie le contenu de la macro qui sera associée au bouton
                Code = Code & "Sub VOIR" & i & "_Click()" & vbCrLf
                Code = Code & "Sheets(""SELRESULT"").Unprotect" & vbCrLf
                Code = Code & "Sheets(""BD"").Range(""O2:Y2"").ClearContents" & vbCrLf
                Code = Code & "Sheets(""BD"").Range(""Q2"")=Sheets(""SELRESULT"").Range(""C" & i + 4 & """).Value" & vbCrLf
                Code = Code & "Sheets(""BD"").Range(""A1:K" & line3 & """).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets(""BD"").Range(""O1:Y2""), CopyToRange:=Sheets(""SELRESULT"").Range(""A" & n + 5 & """), Unique:=False" & vbCrLf
                Code = Code & " With Range(""A" & n + 5 & ":K" & n + 6 & """).Font" & vbCrLf
                Code = Code & "  .ColorIndex = 2 " & vbCrLf
               Code = Code & "End With " & vbCrLf
                Code = Code & "UserForm2.Show" & vbCrLf
               Code = Code & "End Sub" & vbCrLf
 
                Next i
                
                'Ajoute la procédure dans la feuille
                With ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
                    x = .CountOfLines + 1
                    .InsertLines x, Code
                
                End With

cette "re-création" de boutons s'effectue a partir d'une userform n'estce pas ça qui bloque (alors que la 1ere se fait a l'activation d'une feuille) ???

est ce que "les jeux" avec les protections a l'aide de

Code :

.Protect

et

Code :

.Unprotect

peuvent me désactiver les boutons ?????

j'arrive pas a trouver la soluce

aalex_38 · 03/07/2009, 15h54

Citation:

Alors les boutons s'affichent les macros s'ecrivent mais on dirait que l'affectation ne s'est pas faite car un click sur les boutons ne donne rien

Citation:

j'arrive pas a trouver la soluce

Je veux même pas aller plus loin dans la lecture du post, déja il faut vérifier en mettant un point d'arrêt qu'effectivement tu ne passes pas dans le code du bouton.

Citation:

'Ajoute la procédure dans la feuille

Tu ne devrai pas l'ajouter dans le code de l'userform ?

neninio31 · 03/07/2009, 23h06

Re

je récapitule :

1.Je réalise un filtre élaboré qui affiche le résultat (n lignes) sur la feuille "SELRESULT"

2.Chaque ligne non vide de cette feuille se voit crée un bouton VOIR (n boutons voir)

3.Ce bouton VOIR permet de voir en detail la ligne correspondante a l'aide d'un userform

4.sur cette userform il y a un bouton cloturer qui permet de cloturer la ligne

5.une fois la ligne cloturé la feuille "SELRESULT" s'affiche actualisée c'est a dire avec les n-1 lignes et les n-1 boutons associés

c'est la que ca bloque les macros de ces n-1 boutons ne s'ecrive pas dans le code !!!!!!!!!!

ca c'est le code pour l'etape 1 a 3

Code :

Private Sub CommandButton1_Click()
 
 
Dim line As Long
line = Val(TextBox1) + 1
Dim line2 As Long
line2 = Sheets("BD").Range("M2").Value + 2
Dim line3 As Long
line3 = Sheets("BD").Range("M2") + 1
Dim Obj As OLEObject
Dim laMacro As String
Dim x As Integer
Dim k As Integer
Dim i As Integer
Dim n  As Long
n = Sheets("BD").Range("Z2").Value - 1
Dim NomMacro As String, Wb As Workbook
 
 
Sheets("SELRESULT").Unprotect
If ComboBox1.ListIndex = 8 And TextBox7.Text = "" Then
MsgBox "Veuillez choisir un intervenant et renseigner le travail effectué !"
Exit Sub
ElseIf ComboBox1.ListIndex = 8 Then
MsgBox "Veuillez choisir un intervenant !"
Exit Sub
ElseIf TextBox7.Text = "" Then
MsgBox "Veuillez renseigner le travail effectué !"
Exit Sub
Else
If Not TextBox8 = "NON" Then
    MsgBox "Bon de travail cloturé !"
    Else
 
UserForm8.Show
 
Sheets("BD").Range("F" & line) = UserForm2.ComboBox1.Value
Sheets("BD").Range("I" & line) = UserForm2.TextBox7.Value
Sheets("BD").Range("K" & line).Value = Date
MsgBox "Bon de travail cloturé !"
 
 Sheets("SELRESULT").Range("A" & n + 3 & ":K" & line2 + 5).ClearContents
        
        Sheets("BD").Range("O2:Y2").ClearContents
        If Sheets("SELRESULT").TextBox1.Text = "" Then
        Else
        Sheets("BD").Range("O2") = ">=" & CDate(Sheets("SELRESULT").TextBox1.Value)
        End If
        If Sheets("SELRESULT").TextBox2.Text = "" Then
        Else
        Sheets("BD").Range("O2") = ">=" & CDate(Sheets("SELRESULT").TextBox2.Value)
        End If
        If Sheets("SELRESULT").TextBox3.Text = "" Then
        Else
        Sheets("BD").Range("R2") = Sheets("SELRESULT").TextBox3.Text
        End If
        If Sheets("SELRESULT").TextBox4.Text = "" Then
            Else
            If Sheets("SELRESULT").TextBox4.Text = "NON" Then
            Sheets("BD").Range("Y2") = Sheets("SELRESULT").TextBox4.Text
            Else
            If Sheets("SELRESULT").TextBox4.Text = "OUI" Then
            Sheets("BD").Range("Y2") = ">0"
        End If
         End If
         End If
        If Sheets("SELRESULT").TextBox5.Text = "" Then
        Else
        Sheets("BD").Range("U2") = Sheets("SELRESULT").TextBox5.Text
        End If
        If Sheets("SELRESULT").TextBox6.Text = "" Then
        Else
        Sheets("BD").Range("T2") = Sheets("SELRESULT").TextBox6.Text
        End If
        If Sheets("SELRESULT").TextBox7.Text = "" Then
        Else
        Sheets("BD").Range("X2") = Sheets("SELRESULT").TextBox7.Text
        End If
        
        Sheets("SELRESULT").Range("A3:K" & n + 5).ClearContents
        Sheets("BD").Range("A1:K" & line2).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("BD").Range("O1:Y2"), CopyToRange:=Sheets("SELRESULT").Range("A3"), Unique:=False
                    
                    
                    With Sheets("SELRESULT").Columns("C")
                    .HorizontalAlignment = xlCenter
                                  End With
                    
                     With Sheets("SELRESULT").Columns("D")
                               .WrapText = True
                               .ShrinkToFit = True
                      End With
                    
                    With Sheets("SELRESULT").Columns("G")
                               .WrapText = True
                               .ShrinkToFit = True
                      End With
                    
                    
                    With Sheets("SELRESULT").Columns("H")
                               .WrapText = True
                                .ShrinkToFit = True
                      End With
                    
                    With Sheets("SELRESULT").Columns("I")
                              .WrapText = True
                                .ShrinkToFit = True
                       End With
                    
                    With Sheets("SELRESULT").Range("A3:K3").Font
                           .Name = "Arial "
                            .FontStyle = "Gras italique"
                           .Size = 10
                            .ColorIndex = 50
                        End With
                    With Sheets("SELRESULT").Range("A4:K" & line2 + 1).Font
                        
                            .Size = 8
                        End With
 
 
        
                For Each Obj In ActiveSheet.OLEObjects
                 
                    If Left(Obj.Name, 4) = "VOIR" Then Obj.Delete
                    
                    Next Obj
                
                   Set Wb = Workbooks("BON2TRAV v3.xls")
      
                   
                    For i = 0 To n - 1
                    
                        NomMacro = "VOIR" & i & "_Click"
                        SupprimerMacroPrecise Wb, "SELRESULT", NomMacro
                    Next i
 
 
 
            For i = 0 To n - 2
 
 
           Set Obj = ActiveSheet.OLEObjects.Add("Forms.CommandButton.1")
            With Obj
               .Name = "VOIR" & i 'renomme le bouton
                .Left = 800 'position horizontale par rapport au bord gauche de la feuille
            .Top = 200 + i * 35 'position verticale par rapport au bord haut de la feuille
                .Width = 45 'largeur
                .Height = 25 'hauteur
                .Object.Caption = "VOIR"
                .PrintObject = False
            End With
 
 
 
 
 
                'Spécifie le contenu de la macro qui sera associée au bouton
                laMacro = laMacro & "Sub VOIR" & i & "_Click()" & vbCrLf
                laMacro = laMacro & "Sheets(""SELRESULT"").Unprotect" & vbCrLf
                laMacro = laMacro & "Sheets(""BD"").Range(""O2:Y2"").ClearContents" & vbCrLf
               laMacro = laMacro & "Sheets(""BD"").Range(""Q2"")=Sheets(""SELRESULT"").Range(""C" & i + 4 & """).Value" & vbCrLf
                laMacro = laMacro & "Sheets(""BD"").Range(""A1:K" & line3 & """).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets(""BD"").Range(""O1:Y2""), CopyToRange:=Sheets(""SELRESULT"").Range(""A" & n + 5 & """), Unique:=False" & vbCrLf
                laMacro = laMacro & " With Range(""A" & n + 5 & ":K" & n + 6 & """).Font" & vbCrLf
                laMacro = laMacro & "  .ColorIndex = 50 " & vbCrLf
               laMacro = laMacro & "End With " & vbCrLf
                laMacro = laMacro & "UserForm2.Show" & vbCrLf
               laMacro = laMacro & "End Sub" & vbCrLf
 
                Next i
                
                'Ajoute la procédure dans la feuille
                With ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
                    x = .CountOfLines + 1
                    .InsertLines x, Code
                
                End With
                        
        Unload UserForm2
 
 
    End If
    End If
 
Sheets("SELRESULT").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
Sheets("SELRESULT").EnableSelection = xlNoSelection
 
End Sub

et ca c'est le code du bouton cloturer

Code :

Private Sub CommandButton1_Click()
 
 
Dim line As Long
line = Val(TextBox1) + 1
Dim line2 As Long
line2 = Sheets("BD").Range("M2").Value + 2
Dim line3 As Long
line3 = Sheets("BD").Range("M2") + 1
Dim Obj As OLEObject
Dim laMacro As String
Dim x As Integer
Dim k As Integer
Dim i As Integer
Dim n  As Long
n = Sheets("BD").Range("Z2").Value - 1
Dim NomMacro As String, Wb As Workbook
 
 
Sheets("SELRESULT").Unprotect
If ComboBox1.ListIndex = 8 And TextBox7.Text = "" Then
MsgBox "Veuillez choisir un intervenant et renseigner le travail effectué !"
Exit Sub
ElseIf ComboBox1.ListIndex = 8 Then
MsgBox "Veuillez choisir un intervenant !"
Exit Sub
ElseIf TextBox7.Text = "" Then
MsgBox "Veuillez renseigner le travail effectué !"
Exit Sub
Else
If Not TextBox8 = "NON" Then
    MsgBox "Bon de travail cloturé !"
    Else
 
UserForm8.Show
 
Sheets("BD").Range("F" & line) = UserForm2.ComboBox1.Value
Sheets("BD").Range("I" & line) = UserForm2.TextBox7.Value
Sheets("BD").Range("K" & line).Value = Date
MsgBox "Bon de travail cloturé !"
 
 Sheets("SELRESULT").Range("A" & n + 3 & ":K" & line2 + 5).ClearContents
        
        Sheets("BD").Range("O2:Y2").ClearContents
        If Sheets("SELRESULT").TextBox1.Text = "" Then
        Else
        Sheets("BD").Range("O2") = ">=" & CDate(Sheets("SELRESULT").TextBox1.Value)
        End If
        If Sheets("SELRESULT").TextBox2.Text = "" Then
        Else
        Sheets("BD").Range("O2") = ">=" & CDate(Sheets("SELRESULT").TextBox2.Value)
        End If
        If Sheets("SELRESULT").TextBox3.Text = "" Then
        Else
        Sheets("BD").Range("R2") = Sheets("SELRESULT").TextBox3.Text
        End If
        If Sheets("SELRESULT").TextBox4.Text = "" Then
            Else
            If Sheets("SELRESULT").TextBox4.Text = "NON" Then
            Sheets("BD").Range("Y2") = Sheets("SELRESULT").TextBox4.Text
            Else
            If Sheets("SELRESULT").TextBox4.Text = "OUI" Then
            Sheets("BD").Range("Y2") = ">0"
        End If
         End If
         End If
        If Sheets("SELRESULT").TextBox5.Text = "" Then
        Else
        Sheets("BD").Range("U2") = Sheets("SELRESULT").TextBox5.Text
        End If
        If Sheets("SELRESULT").TextBox6.Text = "" Then
        Else
        Sheets("BD").Range("T2") = Sheets("SELRESULT").TextBox6.Text
        End If
        If Sheets("SELRESULT").TextBox7.Text = "" Then
        Else
        Sheets("BD").Range("X2") = Sheets("SELRESULT").TextBox7.Text
        End If
        
        Sheets("SELRESULT").Range("A3:K" & n + 5).ClearContents
        Sheets("BD").Range("A1:K" & line2).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("BD").Range("O1:Y2"), CopyToRange:=Sheets("SELRESULT").Range("A3"), Unique:=False
                    
                    
                    With Sheets("SELRESULT").Columns("C")
                    .HorizontalAlignment = xlCenter
                                  End With
                    
                     With Sheets("SELRESULT").Columns("D")
                               .WrapText = True
                               .ShrinkToFit = True
                      End With
                    
                    With Sheets("SELRESULT").Columns("G")
                               .WrapText = True
                               .ShrinkToFit = True
                      End With
                    
                    
                    With Sheets("SELRESULT").Columns("H")
                               .WrapText = True
                                .ShrinkToFit = True
                      End With
                    
                    With Sheets("SELRESULT").Columns("I")
                              .WrapText = True
                                .ShrinkToFit = True
                       End With
                    
                    With Sheets("SELRESULT").Range("A3:K3").Font
                           .Name = "Arial "
                            .FontStyle = "Gras italique"
                           .Size = 10
                            .ColorIndex = 50
                        End With
                    With Sheets("SELRESULT").Range("A4:K" & line2 + 1).Font
                        
                            .Size = 8
                        End With
 
 
        
                For Each Obj In ActiveSheet.OLEObjects
                 
                    If Left(Obj.Name, 4) = "VOIR" Then Obj.Delete
                    
                    Next Obj
                
                   Set Wb = Workbooks("BON2TRAV v3.xls")
      
                   
                    For i = 0 To n - 1
                    
                        NomMacro = "VOIR" & i & "_Click"
                        SupprimerMacroPrecise Wb, "SELRESULT", NomMacro
                    Next i
 
 
 
            For i = 0 To n - 2
 
 
           Set Obj = ActiveSheet.OLEObjects.Add("Forms.CommandButton.1")
            With Obj
               .Name = "VOIR" & i 'renomme le bouton
                .Left = 800 'position horizontale par rapport au bord gauche de la feuille
            .Top = 200 + i * 35 'position verticale par rapport au bord haut de la feuille
                .Width = 45 'largeur
                .Height = 25 'hauteur
                .Object.Caption = "VOIR"
                .PrintObject = False
            End With
 
 
 
 
 
                'Spécifie le contenu de la macro qui sera associée au bouton
                laMacro = laMacro & "Sub VOIR" & i & "_Click()" & vbCrLf
                laMacro = laMacro & "Sheets(""SELRESULT"").Unprotect" & vbCrLf
                laMacro = laMacro & "Sheets(""BD"").Range(""O2:Y2"").ClearContents" & vbCrLf
               laMacro = laMacro & "Sheets(""BD"").Range(""Q2"")=Sheets(""SELRESULT"").Range(""C" & i + 4 & """).Value" & vbCrLf
                laMacro = laMacro & "Sheets(""BD"").Range(""A1:K" & line3 & """).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets(""BD"").Range(""O1:Y2""), CopyToRange:=Sheets(""SELRESULT"").Range(""A" & n + 5 & """), Unique:=False" & vbCrLf
                laMacro = laMacro & " With Range(""A" & n + 5 & ":K" & n + 6 & """).Font" & vbCrLf
                laMacro = laMacro & "  .ColorIndex = 50 " & vbCrLf
               laMacro = laMacro & "End With " & vbCrLf
                laMacro = laMacro & "UserForm2.Show" & vbCrLf
               laMacro = laMacro & "End Sub" & vbCrLf
 
                Next i
                
                'Ajoute la procédure dans la feuille
                With ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
                    x = .CountOfLines + 1
                    .InsertLines x, Code
                
                End With
                        
        Unload UserForm2
 
 
    End If
    End If
 
Sheets("SELRESULT").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
Sheets("SELRESULT").EnableSelection = xlNoSelection
 
End Sub

Impossible de savoir pourquoi les procédures ne s'ecrivent pas dans le 2ème cas

est ce parce que dans le 1er cas c'est a l'activation dune feuille et dans le 2eme a partir d'un bouton de userform ???

aalex_38 · 06/07/2009, 10h04

Citation:

et dans le 2eme a partir d'un bouton de userform

Le code du bouton de l'USF doit être dans le code de l'USF (Faire F7 dessus pour voir le code).

Dans l'editeur VBE, si tu clique sur le bouton de ton USF, le code correspondant s'affichera, il y a des exemples pour créér du code dans un USF. Je ne l'ai pas sous la main, recherches dans le forum, je pense que tu trouveras.

		Forum des professionnels en informatique > Logiciels > Microsoft Office > Excel > Macros et VBA Excel
[XL-2003] Affectation de macro a des boutons dynamiques

Outils de la discussion
Afficher une version imprimable Envoyer un lien vers cette page par email