Ajouter un bouton en VBA

Résolu

Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention -
Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention - 6 nov. 2015 à 11:48

Bonjour,

Mon code :

(Toutes les variables sont déclarées au préalable)

    Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
    Link:=False, DisplayAsIcon:=False, Left:=200, Top:=100, Width:=100, Height:=35)
    Obj.Name = "BoutonImprimer"
    
'Texte du bouton

    ActiveSheet.OLEObjects(1).Object.Caption = "Imprimer"

'Le texte de la macro
    Code = "Sub BoutonImprimer_Click()" & vbCrLf
    Code = Code & "Call Tester" & vbCrLf
    Code = Code & "End Sub"
'Ajoute la macro en fin de module feuille
    With ThisWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
        .insertlines .CountOfLines + 1, Code
    End With

Il plante sur la ligne :

 With ThisWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule

'L'indice n'appartient pas à la sélection'.... Je ne comprend pas sachant que j'ai utilisé des termes généraux 'ThisWorkbook', 'ActiveSheet'...

Merci d'avance pour votre aide.

Cordialement.

Afficher la suite

4 réponses

f894009 Messages postés 17417 Date d'inscription Statut Membre Dernière intervention 1 717

Bonjour,
avez-vous fait ceci:
ajoutez une référence à "Microsoft Visual Basic for Applications Extensibility" (dans VBA, Outils / Références...).

Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention 65

Bonjour f894009,

Je viens de cocher "Microsoft Visual Basic for Application Extensibility 5.3.

Mais malheureusement le résultat est le même...
0

Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention 65

A titre indicatif, voilà tout le code mais bon.... Ca fait pas mal de lecture :(

Sub Supprimer_Ligne_Ajouter_Feuille()

Dim NumeroJDA As String, NouvelOnglet As Worksheet
Dim C As Range
Dim D As Range
Dim FeuilleOuColler As Worksheet
Dim Trouve As Range, PlageDeRecherche As Range
Dim Valeur_Cherchee As String, AdresseTrouvee As String
Dim DL As Integer
Dim DL2 As Integer
Dim DL3 As Integer
Dim Ligne As Integer
Dim cellule As Range
Dim Obj As Object
Dim Code As String

DL = Sheets("NATIONAL").Cells(Application.Rows.Count, 1).End(xlUp).Row

JourCA = ActiveCell.Value

Ligne = ActiveCell.Row

If ActiveCell.Interior.Color <> RGB(128, 0, 128) Then
    MsgBox ("La sélection actuelle n'est pas de couleur violette et n'est pas donc pas considérée comme une date.")
    Exit Sub
End If

AdresseJour = ActiveCell.Address

Valeur_Cherchee = Sheets("NATIONAL").Range(AdresseJour)

Set PlageDeRecherche = Sheets("EXPORT").Columns(1)

Set Trouve = PlageDeRecherche.Cells.Find(what:=Valeur_Cherchee, LookAt:=xlWhole)

If Trouve Is Nothing Then
    If MsgBox("La date n'a pas été trouvée dans la feuille 'EXPORT', Continuer?", vbYesNo, "Rien dans EXPORT") = vbNo Then
        Exit Sub
    End If

For i = DL To 11 Step -1

If Sheets("NATIONAL").Range("A" & i).Value = "" Then
    If Sheets("NATIONAL").Range("B" & i).Value = "" Then
        If Sheets("NATIONAL").Range("C" & i).Value = "" Then
            Rows(i).Delete
        End If
    End If
End If

Next i

DL = Sheets("NATIONAL").Cells(Application.Rows.Count, 1).End(xlUp).Row

Message:

NumeroJDA = InputBox("Numéro JDA?")

If NumeroJDA = "" Then
    Exit Sub
End If

If FeuilleExiste("JDA" & NumeroJDA) Then
MsgBox ("Impossible de créer la feuille 'JDA" & NumeroJDA & "' car celle-ci existe déjà, entrez un autre JDA.")
GoTo Message
End If
    
   
IndexFeuil = Sheets("EXPORT").Index

Sheets.Add After:=Sheets(IndexFeuil)

ActiveSheet.Name = "JDA" & NumeroJDA

Sheets("NATIONAL").Activate


For Each C In Sheets("NATIONAL").Range(Cells(Ligne + 1, 1), Cells(DL, 1))
 
    If C.Interior.Color = RGB(128, 0, 128) Then
        Ligne2 = C.Row
        Range(Cells(Ligne + 1, 1), Cells(Ligne2 - 1, 23)).Copy Sheets("JDA" & NumeroJDA).Range("A5")
        Exit For
    End If

Next


Sheets("JDA" & NumeroJDA).Activate

DL6 = Sheets("JDA" & NumeroJDA).Cells(Application.Rows.Count, 2).End(xlUp).Row

For i = DL6 To 5 Step -1

If Sheets("JDA" & NumeroJDA).Range("A" & i).Interior.Color <> RGB(255, 0, 0) Then
    If Sheets("JDA" & NumeroJDA).Range("A" & i).Interior.ColorIndex <> xlNone Then
        Rows(i).Delete
    End If
End If

Next i

Application.Union(Columns("A"), Columns("C:E"), Columns("L"), Columns("N"), Columns("Q:R"), Columns("T"), Columns("V")).Delete

DL4 = Sheets("JDA" & NumeroJDA).Cells(Application.Rows.Count, 2).End(xlUp).Row

For i = 1 To DL4
    If Range("H" & i).Value <> "" Then
    Range("J" & i).Value = Range("H" & i).Value - Range("I" & i).Value
    End If
Next i

Sheets("JDA" & NumeroJDA).Range("A1") = JourCA

With Sheets("JDA" & NumeroJDA).Range("B3")
    .Value = "JDA " & NumeroJDA & "******"
    .Font.Bold = True
    .Font.Size = 14
End With

With Sheets("JDA" & NumeroJDA)
    .Columns(1).ColumnWidth = 10.29
    .Columns(2).ColumnWidth = 23.57
    .Columns(3).ColumnWidth = 2.57
    .Columns(4).ColumnWidth = 23
    .Columns(5).ColumnWidth = 2.43
    .Columns(6).ColumnWidth = 5.71
    .Columns(7).ColumnWidth = 5.71
    .Columns(8).ColumnWidth = 5.29
    .Columns(9).ColumnWidth = 4.29
    .Columns(10).ColumnWidth = 6.29
    .Columns(11).ColumnWidth = 18.57
    .Columns(12).ColumnWidth = 18.14
    .Columns(13).ColumnWidth = 7.29
End With
    
Sheets("JDA" & NumeroJDA).Cells.Interior.Color = RGB(255, 255, 255)

For Each cellule In Range(Cells(5, 1), Cells(DL4, 13))

    If cellule <> "" Then cellule.Borders.Weight = xlThin
    cellule.HorizontalAlignment = xlLeft
    
Next

PiedDePage = "JDA " & NumeroJDA & "***" & "PAGE &P/&N"

With Sheets("JDA" & NumeroJDA).PageSetup
DL5 = Sheets("JDA" & NumeroJDA).Cells(Application.Rows.Count, 1).End(xlUp).Row
        .Zoom = False
        .FitToPagesTall = False
        .FitToPagesWide = 1
        .Orientation = xlLandscape
        .LeftHeader = "&""-,Gras""JDA " & NumeroJDA & "***PAGE &P/&N"
        .PrintArea = Range("A1:M" & DL5).Address
End With

Sheets("JDA" & NumeroJDA).Cells(DL4 + 1, 10) = Application.WorksheetFunction.Sum(Range(Cells(5, 10), Cells(DL4, 10)))



Else '****
    AdresseTrouvee = Trouve.Row

For i = DL To 11 Step -1

If Sheets("NATIONAL").Range("A" & i).Value = "" Then
    If Sheets("NATIONAL").Range("B" & i).Value = "" Then
        If Sheets("NATIONAL").Range("C" & i).Value = "" Then
            Rows(i).Delete
        End If
    End If
End If

Next i

DL = Sheets("NATIONAL").Cells(Application.Rows.Count, 1).End(xlUp).Row

Message2:

NumeroJDA = InputBox("Numéro JDA?")

If NumeroJDA = "" Then
    Exit Sub
End If

If FeuilleExiste("JDA" & NumeroJDA) Then
MsgBox ("Impossible de créer la feuille 'JDA" & NumeroJDA & "' car celle-ci existe déjà, entrez un autre JDA.")
GoTo Message2
End If
    

IndexFeuil = Sheets("EXPORT").Index

Sheets.Add After:=Sheets(IndexFeuil)

ActiveSheet.Name = "JDA" & NumeroJDA

Sheets("NATIONAL").Activate


For Each C In Sheets("NATIONAL").Range(Cells(Ligne + 1, 1), Cells(DL, 1))
 
    If C.Interior.Color = RGB(128, 0, 128) Then
        Ligne2 = C.Row
        Range(Cells(Ligne + 1, 1), Cells(Ligne2 - 1, 23)).Copy Sheets("JDA" & NumeroJDA).Range("A5")
        Exit For
    End If
    
Next

DL2 = Sheets("JDA" & NumeroJDA).Cells(Application.Rows.Count, 1).End(xlUp).Row

DL3 = Sheets("EXPORT").Cells(Application.Rows.Count, 1).End(xlUp).Row

For i = DL3 To 7 Step -1
    If Range("A" & i) = "" Then
        If Range("B" & i) = "" Then
            If Range("C" & i) = "" Then
                Rows(i).Delete
            End If
        End If
    End If
Next i

DL3 = Sheets("EXPORT").Cells(Application.Rows.Count, 1).End(xlUp).Row

With Sheets("EXPORT")
    For Each D In .Range(.Cells(AdresseTrouvee + 1, 1), .Cells(DL3, 1))
        If D.Interior.Color = RGB(128, 0, 128) Then
            Ligne3 = D.Row
            .Range(.Cells(AdresseTrouvee + 1, 1), .Cells(Ligne3 - 1, 23)).Copy Sheets("JDA" & NumeroJDA).Cells(DL2 + 1, 1)
            Exit For
        End If
    Next
End With

Set PlageDeRecherche = Nothing
Set Trouve = Nothing

Sheets("JDA" & NumeroJDA).Select

DL6 = Sheets("JDA" & NumeroJDA).Cells(Application.Rows.Count, 1).End(xlUp).Row

For i = DL6 To 5 Step -1

If Sheets("JDA" & NumeroJDA).Range("A" & i).Interior.Color <> RGB(255, 0, 0) Then
    Rows(i).Delete
End If

Next i

Application.Union(Columns("A"), Columns("C:E"), Columns("L"), Columns("N"), Columns("Q:R"), Columns("T"), Columns("V")).Delete

DL4 = Sheets("JDA" & NumeroJDA).Cells(Application.Rows.Count, 1).End(xlUp).Row

For i = 1 To DL4
    If Range("H" & i).Value <> "" Then
    Range("J" & i).Value = Val(Range("H" & i).Value) - Val(Range("I" & i).Value)
    End If
Next i

Sheets("JDA" & NumeroJDA).Range("A1") = JourCA

With Sheets("JDA" & NumeroJDA).Range("B3")
    .Value = "JDA " & NumeroJDA & "******"
    .Font.Bold = True
    .Font.Size = 14
End With

With Sheets("JDA" & NumeroJDA)
    .Columns(1).ColumnWidth = 10.29
    .Columns(2).ColumnWidth = 23.57
    .Columns(3).ColumnWidth = 2.57
    .Columns(4).ColumnWidth = 23
    .Columns(5).ColumnWidth = 2.43
    .Columns(6).ColumnWidth = 5.71
    .Columns(7).ColumnWidth = 5.71
    .Columns(8).ColumnWidth = 5.29
    .Columns(9).ColumnWidth = 4.29
    .Columns(10).ColumnWidth = 6.29
    .Columns(11).ColumnWidth = 18.57
    .Columns(12).ColumnWidth = 18.14
    .Columns(13).ColumnWidth = 7.29
End With
    
Sheets("JDA" & NumeroJDA).Cells.Interior.Color = RGB(255, 255, 255)

For Each cellule In Range(Cells(5, 1), Cells(DL4, 13))

    If cellule <> "" Then cellule.Borders.Weight = xlThin
    cellule.HorizontalAlignment = xlLeft
    
Next

PiedDePage = "JDA " & NumeroJDA & "***" & "PAGE &P/&N"

With Sheets("JDA" & NumeroJDA).PageSetup
DL5 = Sheets("JDA" & NumeroJDA).Cells(Application.Rows.Count, 1).End(xlUp).Row
        .Zoom = False
        .FitToPagesTall = False
        .FitToPagesWide = 1
        .Orientation = xlLandscape
        .LeftHeader = "&""-,Gras""JDA " & NumeroJDA & "***PAGE &P/&N"
End With

Range("A5:M" & DL5).Select
    Sheets("JDA" & NumeroJDA).Sort.SortFields.Clear
    Sheets("JDA" & NumeroJDA).Sort.SortFields.Add Key:=Range("A5:A" & DL5), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("JDA" & NumeroJDA).Sort
        .SetRange Range("A5:M" & DL5)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
Sheets("JDA" & NumeroJDA).Cells(DL4 + 1, 10) = Application.WorksheetFunction.Sum(Range(Cells(5, 10), Cells(DL4, 10)))

End If

    Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
    Link:=False, DisplayAsIcon:=False, Left:=600, Top:=10, Width:=100, Height:=35)
    Obj.Name = "BoutonImprimer"
    
Sheets("JDA" & NumeroJDA).Select
    
'Texte du bouton

    ActiveSheet.OLEObjects(1).Object.Caption = "Imprimer"

'Le texte de la macro
    Code = "Sub BoutonImprimer_Click()" & vbCrLf
    Code = Code & "Call Tester" & vbCrLf
    Code = Code & "End Sub"
'Ajoute la macro en fin de module feuille
    With ThisWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
        .insertlines .CountOfLines + 1, Code
    End With
    
Range("A5").Select

End Sub

Sub Tester()

DL5 = ActiveSheet.Cells(Application.Rows.Count, 1).End(xlUp).Row

    With ActiveSheet.PageSetup
        .PrintArea = Range("A1:M" & DL5).Address
    End With
    
Application.Dialogs(xlDialogPrint).Show


End Sub

Et le code plante bien sur la ligne :

 With ThisWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule

Réponse 2 / 4
Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention 65

Pour plus de simplicité, voici mon fichier anonymé.

Sélectionnez une date dans la feuille "NATIONAL" (en violet) de la colonne A et cliquez sur JOURNAL en haut du fichier pour faire tourner la macro et constatez l'erreur.

Merci d'avance à ceux qui auront le courage et la gentillesse de m'aider.

Cordialement.

https://www.cjoint.com/c/EKfqZ0Irh4f
0
Réponse 3 / 4
cs_Le Pivert Messages postés 8437 Statut Contributeur 730

Bonjour,

voir ici la façon de créer un bouton:

https://forums.commentcamarche.net/forum/affich-32733666-bouton-qui-s-auto-detruit#top
0
1. Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention 65
  
  Ca marche niquel !
  
  Mille merci cs_Le Pivert !
  
  0
2. Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention 65
  
  Petite question supplémentaire, est-il possible, toujours en VBA, de configurer le bouton pour qu'il ne s'imprime pas si j'imprime la feuille? Un code VBA qui fasse l'équivalent d'aller dans les propriétés du bouton et de décocher la case?
  
  Merci d'avance.
  
  0
Réponse 4 / 4
cs_Le Pivert Messages postés 8437 Statut Contributeur 730

Je pense que dans ton code imprimer, en mettant la propriété de ton bouton Visible à False, cela doit le faire!

Je n'ai pas essayé!
0
1. Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention 65
  
  Sub Imprimer() MonBouton1.Visible = False DL5 = ActiveSheet.Cells(Application.Rows.Count, 1).End(xlUp).Row With ActiveSheet.PageSetup .PrintArea = Range("A1:M" & DL5).Address End With Application.SendKeys "^p" End Sub
  
  Il veut pas... 'Objet requis' sur la ligne :
  
  MonBouton1.Visible = False
  
  Bizarre qu'il n'existe pas de code pour décocher la case directement en créant le bouton... Je n'en trouve pas sur le net.
  
  0
2. Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention 65
  
  Trouvé !!
  
  Il faut rajouter quand on créé le bouton la ligne :
  
  .PrintObject = False
  
  Dans le with.
  
  Merci beaucoup !!
  
  0
3. Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention 65
  
  Petite question de débutant qui me pose problème depuis quelques temps déjà qui n'a rien à voir mais si tu peux me filer un tout petit coup de main...
  
  Comment faire pour faire entrer une variable dans une boucle?
  
  Je m'explique voilà le code :
  
  For i = 3 To ActiveWorkbook.Sheets.Count DL & i = Sheets(i).Cells(Application.Rows.Count, 10).End(xlUp).Row" Next i
  
  Mais bien sûr 'DL & i' ne veut rien dire en VBA...
  
  Je voudrais créer un DL (donc dernière ligne) pour chaque feuille présente dans le classeur. Comment est-ce que je peux l'écrire?
  
  Merci beaucoup d'avance.
  
  0
  1. f894009 Messages postés 17417 Date d'inscription Statut Membre Dernière intervention 1 717 > Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention
    
    Bonjour a vous tous,
    
    Dim DL() As Byte 'mettre Integer si plus de 254 onglets ReDim DL(ActiveWorkbook.Sheets.Count) For i = 3 To ActiveWorkbook.Sheets.Count DL(i) = Sheets(i).Cells(Application.Rows.Count, 10).End(xlUp).Row Next i
    
    0
4. Kuartz Messages postés 852 Date d'inscription Statut Membre Dernière intervention 65
  
  Bonjour f894009,
  
  En réfléchissant un peu, j'ai trouvé ma méthode à moi. Certes bien moins optimisée, donc je vais utiliser la votre. Mais je suis content d'avoir résolu mon problème tout seul quand même :)
  
  Mon code complet :
  
  Sub TEST() Dim i As Integer Dim DL_i As Long Dim CA As Long CA = 0 For i = 3 To ActiveWorkbook.Sheets.Count CA = CA + Sheets(i).Cells(DL(i), 10).Value Next i MsgBox (CA) End Sub Function DL(j As Integer) DL = Sheets(j).Cells(Application.Rows.Count, 10).End(xlUp).Row End Function
  
  Merci beaucoup pour votre aide !!
  
  0

Ajouter un bouton en VBA

4 réponses

Discussions similaires

Newsletters