1. Accueil
  2. Forum Codes-Sources
  3. Visual Basic
Sujet Précédent Sujet Suivant

Mettre une macro dans un bouton avec VB6

Résolu
cs_petchy
Messages postés
710
Date d'inscription
jeudi 20 février 2003
Statut
Membre
Dernière intervention
19 mai 2015
 - 21 avril 2006 à 10:58
cs_petchy
Messages postés
710
Date d'inscription
jeudi 20 février 2003
Statut
Membre
Dernière intervention
19 mai 2015
 - 21 avril 2006 à 12:10
bonjour
MichelXLD m'a donner un code pour mettre un bouton à l'ouverture d'une feuille Excel que je crée par l'intermediaire de VB6,voici le code :
Private Sub Command2_Click()
Dim ExcelApp As Excel.Application
Dim Wb As Excel.Workbook
Dim Obj As Excel.OLEObject
Dim laMacro As String
Dim x As Integer


Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
Set Wb = ExcelApp.Workbooks.Add(1)



Set Obj = Wb.Worksheets(1).OLEObjects.Add("Forms.CommandButton.1")
With Obj
.Left = 10
.Top = 5
.Width = 80
.Height = 30
.Object.Caption = "Supprimer"
End With
Mac = "call FichierCleaner"
laMacro = "Sub CommandButton1_Click()" & vbCrLf
laMacro = laMacro & Mac & vbCrLf
laMacro = laMacro & "End Sub"


With Wb.VBProject.VBComponents(ActiveSheet.Name).CodeModule
x = .CountOfLines + 1
.InsertLines x, laMacro
End With
End Sub
mais la ligne qui est en rouge me pose un soucis,en fait je voudrais mettre cette macro si dessous sur l'évenement click du bouton
Sub FichierCleaner()

Dim Donnees As Range
Dim NbreLignes&, Lig&, PremErreur&


Set Donnees = Range([b2], [e2].End(xlDown)) 'Définit le champ "Données"
NbreLignes = Donnees.Rows.Count 'Définit le Nbre de Lignes dans Donnéees

Application.ScreenUpdating = False 'Fige l'affichage (Gain temps)

With Donnees
.Copy 'Copie les formules du champ Donnees
.PasteSpecial Paste:=xlValues 'Fait un collage spéciale Valeurs
Application.CutCopyMode = False 'quitte le mode couper-coller
.Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Header:=xlNo 'Effectue un tri
Columns("A:A").Delete Shift:=xlToLeft 'Supprime la colonne A
For Lig = 1 To NbreLignes 'boucle à partir de la ligne 1 de Donnees
If IsError(.Cells(Lig, 1)) Then 'si en colonne 1 il y a une erreur
'Détruit toutes les lignes à partir de l'erreur et jusqu'à la dernière ligne de Données
Rows(Lig & ":" & .SpecialCells(xlCellTypeLastCell).Rows.Row).Delete Shift:=xlUp
Exit For 'Sort de la boucle
End If
Next Lig
End With
Application.ScreenUpdating = True 'Réactive l'affichage

End Sub
Quelqu'un aurait il une idée pour intégré le code si dessus .
merci
@plus
petchy

6 réponses

Réponse 1 / 6
econs
Messages postés
4030
Date d'inscription
mardi 13 mai 2003
Statut
Modérateur
Dernière intervention
23 décembre 2008
 23
21 avril 2006 à 11:11
Salut,





Ben disons que çà sera un petit peu long. Il suffit juste de compléter la variable laMacro :





Private Sub Command2_Click()
Dim ExcelApp As Excel.Application
Dim Wb As Excel.Workbook
Dim Obj As Excel.OLEObject
Dim laMacro As String
Dim x As Integer
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
Set Wb = ExcelApp.Workbooks.Add(1)




Set Obj = Wb.Worksheets(1).OLEObjects.Add("Forms.CommandButton.1")
With Obj
.Left = 10
.Top = 5
.Width = 80
.Height = 30
.Object.Caption = "Supprimer"
End With
Mac = "call FichierCleaner"
laMacro = "Sub CommandButton1_Click()" & vbCrLf
laMacro = laMacro & Mac & vbCrLf

laMacro = laMacro & "End Sub" & vbCrLf









laMacro = laMacro & "Sub FichierCleaner()" & vbCfLf

laMacro = laMacro & "Dim Donnees As Range" & vbCfLf

laMacro = laMacro & "Dim NbreLignes&, Lig&, PremErreur&" & vbCfLf

laMacro laMacro & "Set Donnees Range([b2], [e2].End(xlDown)) 'Définit le champ ""Données""" & vbCfLf

laMacro laMacro & "NbreLignes Donnees.Rows.Count 'Définit le Nbre de Lignes dans Donnéees" & vbCfLf

laMacro laMacro & "Application.ScreenUpdating False 'Fige l'affichage (Gain temps)" & vbCfLf


laMacro = laMacro & "With Donnees" & vbCfLf

laMacro = laMacro & ".Copy 'Copie les formules du champ Donnees" & vbCfLf

laMacro = laMacro & ".PasteSpecial Paste:=xlValues 'Fait un collage spéciale Valeurs" & vbCfLf

laMacro laMacro & "Application.CutCopyMode False 'quitte le mode couper-coller" & vbCfLf

laMacro = laMacro & ".Sort Key1:=Range(""D2""), Order1:=xlAscending, Key2:=Range(""C2"") _" & vbCfLf

laMacro = laMacro & ", Order2:=xlAscending, Header:=xlNo 'Effectue un tri" & vbCfLf

laMacro = laMacro & "Columns(""A:A"").Delete Shift:=xlToLeft 'Supprime la colonne A" & vbCfLf

laMacro laMacro & "For Lig 1 To NbreLignes 'boucle à partir de la ligne 1 de Donnees" & vbCfLf

laMacro = laMacro & "If IsError(.Cells(Lig, 1)) Then 'si en colonne 1 il y a une erreur" & vbCfLf

laMacro = laMacro & "'Détruit toutes les lignes à partir de l'erreur et jusqu'à la dernière ligne de Données" & vbCfLf

laMacro = laMacro & "Rows(Lig & "":"" & .SpecialCells(xlCellTypeLastCell).Rows.Row).Delete Shift:=xlUp" & vbCfLf

laMacro = laMacro & "Exit For 'Sort de la boucle" & vbCfLf

laMacro = laMacro & "End If" & vbCfLf

laMacro = laMacro & "Next Lig" & vbCfLf

laMacro = laMacro & "End With" & vbCfLf

laMacro laMacro & "Application.ScreenUpdating True 'Réactive l'affichage" & vbCfLf


laMacro = laMacro & "End Sub" & vbCfLf





With Wb.VBProject.VBComponents(ActiveSheet.Name).CodeModule
x = .CountOfLines + 1
.InsertLines x, laMacro
End With
End Sub


Manu
3
Réponse 2 / 6
jrivet
Messages postés
7393
Date d'inscription
mercredi 23 avril 2003
Statut
Membre
Dernière intervention
6 avril 2012
 59
21 avril 2006 à 11:11
Salut,

Si j ai bien compris tu veux remplacer le "Call FichierCleaner" Par le code de FichierCleaner.

Dans ce cas essaie ceci.

Mac = "Dim Donnees As Range" & _
"Dim NbreLignes&, Lig&, PremErreur&" & _
" Set Donnees = Range([b2], [e2].End(xlDown)) 'Définit le champ Données " & _
" NbreLignes = Donnees.Rows.Count 'Définit le Nbre de Lignes dans Donnéees" & _
" Application.ScreenUpdating = False 'Fige l'affichage (Gain temps)" & _
" With Donnees" & _
".Copy 'Copie les formules du champ Donnees" & _
".PasteSpecial Paste:=xlValues 'Fait un collage spéciale Valeurs" & _
"Application.CutCopyMode = False 'quitte le mode couper-coller" & _
".Sort Key1:=Range(""D2""), Order1:=xlAscending, Key2:=Range(""C2"") _" & _
", Order2:=xlAscending, Header:=xlNo 'Effectue un tri" & _
"Columns(""A:A"").Delete Shift:=xlToLeft 'Supprime la colonne A" & _
"For Lig = 1 To NbreLignes 'boucle à partir de la ligne 1 de Donnees" & _
"If IsError(.Cells(Lig, 1)) Then 'si en colonne 1 il y a une erreur" & _
"'Détruit toutes les lignes à partir de l'erreur et jusqu'à la dernière ligne de Données" & _
"Rows(Lig & "":"" & .SpecialCells(xlCellTypeLastCell).Rows.Row).Delete Shift:=xlUp" & _
"Exit For 'Sort de la boucle" & _
"End If" & _
"Next Lig" & _
"End With" & _
"Application.ScreenUpdating = True 'Réactive l'affichage" & _
"End Sub"
laMacro = "Sub CommandButton1_Click()" & vbCrLf
laMacro = laMacro & Mac & vbCrLf
laMacro = laMacro & "End Sub"

@+, Julien
Pensez: Moteur de Recherche, Réponse Acceptée
0
Réponse 3 / 6
jrivet
Messages postés
7393
Date d'inscription
mercredi 23 avril 2003
Statut
Membre
Dernière intervention
6 avril 2012
 59
21 avril 2006 à 11:13
RE:

OUPS, je me suis totalement planter en fait j ai oublier les VBCRLF pour les retours a la lignes dans le code..... (ou la la faudrait que j ouvre les yeux un peu...)

> petchy: OUBLIE MON POST (meme si y avait de l'idee)
@+, Julien
Pensez: Moteur de Recherche, Réponse Acceptée
0
Réponse 4 / 6
cs_juju12
Messages postés
966
Date d'inscription
samedi 3 avril 2004
Statut
Membre
Dernière intervention
4 mars 2010
 4
21 avril 2006 à 11:14
Salut;
Si tu remplaces "call FichierCleaner" par le code contenu dans ta Sub FichierCleaner, ça marchera peut-être.
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 6
cs_juju12
Messages postés
966
Date d'inscription
samedi 3 avril 2004
Statut
Membre
Dernière intervention
4 mars 2010
 4
21 avril 2006 à 11:16
oups désolé econs & jrivet le temps que je valide vous aviez déjà répondu
0
Réponse 6 / 6
cs_petchy
Messages postés
710
Date d'inscription
jeudi 20 février 2003
Statut
Membre
Dernière intervention
19 mai 2015
 3
21 avril 2006 à 12:10
salut
merci les à tous,vous etes super,c'est nickel
@ plus
Petchy
0