mettre une macro dans un bouton avec VB6Résolu

Question

bonjour
MichelXLD m'a donner un code pour mettre un bouton &#224; l'ouverture d'une feuille Excel que je cr&#233;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'&#233;venement click du bouton 
Sub FichierCleaner()

Dim Donnees As Range
Dim NbreLignes&, Lig&, PremErreur&


  Set Donnees = Range([b2], [e2].End(xlDown)) 'D&#233;finit le champ "Donn&#233;es"
  NbreLignes = Donnees.Rows.Count 'D&#233;finit le Nbre de Lignes dans Donn&#233;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&#233;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 &#224; partir de la ligne 1 de Donnees
      If IsError(.Cells(Lig, 1)) Then 'si en colonne 1 il y a une erreur
        'D&#233;truit toutes les lignes &#224; partir de l'erreur et jusqu'&#224; la derni&#232;re ligne de Donn&#233;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&#233;active l'affichage
  
End Sub
Quelqu'un aurait il une id&#233;e  pour int&#233;gr&#233; le code si dessus .
merci
@plus
petchy

econs · Accepted Answer

Salut,





Ben disons que &#231;&#224; sera un petit peu long. Il suffit juste de compl&#233;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&#233;finit le champ ""Donn&#233;es""" & vbCfLf

laMacro laMacro & "NbreLignes Donnees.Rows.Count 'D&#233;finit le Nbre de Lignes dans Donn&#233;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&#233;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 &#224; 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&#233;truit toutes les lignes &#224; partir de l'erreur et jusqu'&#224; la derni&#232;re ligne de Donn&#233;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&#233;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

jrivet · Answer

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&#233;finit le champ Donn&#233;es " & _
"  NbreLignes = Donnees.Rows.Count 'D&#233;finit le Nbre de Lignes dans Donn&#233;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&#233;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 &#224; partir de la ligne 1 de Donnees" & _
      "If IsError(.Cells(Lig, 1)) Then 'si en colonne 1 il y a une erreur" & _
        "'D&#233;truit toutes les lignes &#224; partir de l'erreur et jusqu'&#224; la derni&#232;re ligne de Donn&#233;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&#233;active l'affichage" & _
"End Sub"
laMacro = "Sub CommandButton1_Click()" & vbCrLf
laMacro = laMacro & Mac & vbCrLf
laMacro = laMacro & "End Sub"

@+, Julien 
Pensez: Moteur de Recherche, R&#233;ponse Accept&#233;e

jrivet · Answer

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&#233;ponse Accept&#233;e

cs_juju12 · Answer

Salut;
Si tu remplaces "call FichierCleaner" par le code contenu dans ta Sub FichierCleaner, &#231;a marchera peut-&#234;tre.

cs_juju12 · Answer

oups d&#233;sol&#233; econs & jrivet le temps que je valide vous aviez d&#233;j&#224; r&#233;pondu

cs_petchy · Answer

salut
merci les à tous,vous etes super,c'est nickel
@ plus
Petchy

Mettre une macro dans un bouton avec VB6

6 réponses

Discussions similaires