racourcir code VBA avec goto

[fredh]

Bonsoir le forum

J'ai creer un fichier excell avec des USF qui comporte chacun 12 bouton de commande pour suavegarder dans autant de destination differentes.

J'ai creer mes premier bouton de commandes et je me rend compte que la moitier du code est communs aux douze boutons de commandes

J'ai essayez avec goto mais il me marque que j'ai des erreur Else sans If

Quelqu'un pourrat il me guider pour que je puisse economiser du code et des corrections par la suite, en integrant des goto

Je vous joint le fichier.

Explication eb feuille 2 je stocke les repertoires que j'utilise par la suite pour mes boutons de commande. Je n'ai pas trouver une autre solutions pour stocker mes repertoire de destination.

merci @+

 

[PascalXLD]

Re : racourcir code VBA avec goto

Bonjour

PAS DE GOTO

C'est archaïque du temps du basic

Fais plutot soit une procédure où tu lui passes un paramètre qui doit être pris en compte et tu appelles cette procédure avec le parmaètre pour chaque bouton
soit un module de classe un peu plus compliqué mais bon exercice

bonne soirée

 

[flo2002]

Re : racourcir code VBA avec goto

bonjour à tous,
je sais pas si je repond à ta question mais j'ai mis par exemple pur S01:
Private Sub S01_Click()
mess = InputBox("entrez le nom du répertoire pour S01", "Chemin du répertoire", Sheets("Feuil2").Range("B1"))
If mess = "" Then
Unload Me
Else: Sheets("Feuil2").Range("A2") = mess
Unload Me
End If
End Sub

donc voila je crois c'etais une erreur dans la redaction, ya encore le else: qui me semble bizar...les pros confirmeront
bonne soirée

 

[fredh]

Re : racourcir code VBA avec goto

Bonjour a pascal76, jmps, flo2002, le fil

Pascal par procedure tu veut dire quelque chose du genre

Sub Muster_Click()
    Path = Sheets("feuil2").Range("A1").Value
    If Range("a3").Value = "" Then
        [COLOR="red"]call aucun_nom[/COLOR]
        Else
        If Fichier = Fichier_Origine Then
            [COLOR="red"]Call meme_nom[/COLOR]
            Else
            If Dir(Path & "\" & Fichier) = "" Then
                [COLOR="red"]Call create[/COLOR]
                 Else
                [COLOR="red"]Call exist[/COLOR]
            End If
        End If
    End If
    Unload Me
End Sub

j'ai mis dans un module

Sub aucun_nom()
        CreateObject("WScript.Shell").Popup "Aucun nom", 2, "Fred"
End Sub

Sub meme_nom()
    CreateObject("WScript.Shell").Popup "Meme nom, aucune action", 2, "Fred"
End Sub

Sub create()
    ThisWorkbook.SaveAs Filename:=Path & Fichier
'   Kill Fichier_Origine
    CreateObject("WScript.Shell").Popup "Nouveau fichier creer et supresion de l'ancien", 2, "Fred"
End Sub

Sub exist()
    CreateObject("WScript.Shell").Popup "le fichier existe deja", 2, "Fred"
End Sub

Apparement je n'arrive pas a passer les parametres, pourtant dans thisworkbook

Sub definition()
    Dim Fichier As String
    Dim Fichier_Origine As String
    Dim Path As String
    Fichier_Origine = ActiveWorkbook.FullName
    Fichier = Range("a3").Value & ".xls"
    End Sub

puis pour le autres boutons

Sub [COLOR="red"]S01[/COLOR]_Click()
    Path = Sheets("feuil2").Range("[COLOR="red"]A2[/COLOR]").Value
    If Range("a3").Value = "" Then
        call aucun_nom
        Else
        If Fichier = Fichier_Origine Then
            Call meme_nom
            Else
            If Dir(Path & "\" & Fichier) = "" Then
                Call create
                 Else
                Call exist
            End If
        End If
    End If
    Unload Me
End Sub

Sub [COLOR="red"]S02[/COLOR]_Click()
    Path = Sheets("feuil2").Range("[COLOR="Red"]A3[/COLOR]").Value
    If Range("a3").Value = "" Then
        call aucun_nom
        Else
        If Fichier = Fichier_Origine Then
            Call meme_nom
            Else
            If Dir(Path & "\" & Fichier) = "" Then
                Call create
                 Else
                Call exist
            End If
        End If
    End If
    Unload Me
End Sub

etc... pour boutons S03 a S12

 

[PascalXLD]

Re : racourcir code VBA avec goto

RE

Regarde tous tes boutons ressemblent à cela


Il n'y a que ce que tu as mis en rouge qui change

donc autant créer une procédure unique où tu passes comme argument l'adresse de ta cellule

du genre

Sub toto(MaCellule as string)
Path = Sheets("feuil2").Range(macellule).Value
If Range("a3").Value = "" Then
call aucun_nom
Else
If Fichier = Fichier_Origine Then
Call meme_nom
Else
If Dir(Path & "\" & Fichier) = "" Then
Call create
Else
Call exist
End If
End If
End If
Unload Me
End Sub

Sub S01_Click()
toto("A2")
End Sub

Sub S02_Click()
toto("A3")
End Sub

Etc

Voilà c'est une idée je pense à developper et a mettre en oeuvre

Bon courage

 

[fredh]

Re : racourcir code VBA avec goto

Yes !!!!

Merci Pascal76 c'est le pied.

voici ton idées apliquer au contexte :
dans un module

Sub toto(MaCellule As String)
    Dim Fichier As String
    Dim Fichier_Origine As String
    Dim Path As String
    
    Fichier_Origine = ActiveWorkbook.FullName
    Fichier = Sheets("feuil1").Range("a3").Value & ".xls"
    Path = Sheets("feuil2").Range(MaCellule).Value

    If Sheets("feuil1").Range("a3").Value = "" Then
        CreateObject("WScript.Shell").Popup "Aucun nom", 1, "Fred"
    Else
        If Fichier = Fichier_Origine Then
            CreateObject("WScript.Shell").Popup "Meme nom, aucune action", 1, "Fred"
        Else
            If Dir(Path & "\" & Fichier) = "" Then
               ThisWorkbook.SaveAs Filename:=Path & Fichier
               Kill Fichier_Origine
               CreateObject("WScript.Shell").Popup "Nouveau fichier creer et supresion de l'ancien", 1, "Fred"
            Else
            CreateObject("WScript.Shell").Popup "le fichier existe deja", 1, "Fred"
            End If
         End If
    End If
    Unload Save_prb
End Sub

puis le code du USF :

Sub Muster_Click()
toto ("A1")
End Sub

Sub S01_Click()
toto ("A2")
End Sub

Sub S02_Click()
toto ("A3")
End Sub

Sub S03_Click()
toto ("A4")
End Sub

Sub S04_Click()
toto ("A5")
End Sub

Sub S05_Click()
toto ("A6")
End Sub

Sub S06_Click()
toto ("A7")
End Sub

Sub S07_Click()
toto ("A8")
End Sub

Sub S08_Click()
toto ("A9")
End Sub

Sub S09_Click()
toto ("A10")
End Sub

Sub S10_Click()
toto ("A11")
End Sub

Sub S11_Click()
toto ("A12")
End Sub

Sub S12_Click()
toto ("A13")
End Sub

Moi qui suis débutant j'apprend enormement a la lecture de vos code. Maintenant je sais passer des parametres....

De plus le code est minuscule comparer au debut...

Merci encore et au plaisir de te (vous) relire.

PS j'ai d'autres fil d'ouvert ou je cale encore, alors peut etre j'aurais la chance de vous retrouver la bas.

 

[Mytå]

Re : racourcir code VBA avec goto

Salut le Forum

Juste pour ajouter au Forum

Un module de classe pour gérer le click des boutons du Userform

Je n'ai travaillé que le code pour le CommandButon1 de la feuille

Mytå

P.S. Pas géré la gestion d'erreur si le répertoire n'existe pas

 

[fredh]

Re : racourcir code VBA avec goto

Bonjour myta
Waouw je suis larguer avec ton modul de classe, mais je vais etudier tout cela .

Merci et bonne soirée

 

[fredh]

Re : racourcir code VBA avec goto

Bonsoir le fil

Pascal76 j'ariive a passer des argument vers le bas mais pas vers le haut.
Je m'explique

dans un premiere macro j'appelle une deuxieme macro avec un argument.
Puis de la deuxiem macros j'appele une troisieme avec aussi un argument.
La deuxieme et troisieme macro recoivent leur argument.
Mais je n'arrive pas faire remonter un argument de la troisieme macro vers la deuxieme et de la deuxieme ver la premiere.
J'ai essayer de travailler avec le mem argument pour les trois macro mais chaque macro l'utilise independament.

Expication dans la troisieme macros je fait une gestion d'erreur. Si erreur il y a je ne doit pas executer le code qui se situe apres l'appel dans la 1er macro

Comment faire pour palier ce probleme ?

la premiere macros

Public Sub Macro_1()
Dim erreur_macro1

    Save_as    [COLOR="Lime"]'appel 2em macro[/COLOR]
    If [COLOR="Red"]Erreur_Fred [/COLOR]<> "" Then [COLOR="red"]'cette argument doit ettre renvoyer par saveAs[/COLOR]
   CreateObject("WScript.Shell").Popup Erreur_Fred, 2, "Macro1"
      Else
[COLOR="red"]'ici les actions a effectuer apres SaveAs mais seulemnet si SaveAs n'a pas d'erreur[/COLOR]
       Application.DisplayAlerts = True 'Fred
    TesterPlage.TesterPlage 
    NamenFeld_0.NamenFeld_0 'Fred
    Formatage2.Formatage2 'Fred
 End If
End Sub

la 2em macro dans un module de perso.xls

Public Sub Save_as()
[COLOR="red"]Dim erreur_SaveAs[/COLOR]

If Sheets(1).Range("AA3").Value = "" Then
Fred ("A1")   [COLOR="Lime"]'appel 3em macro avec argument[/COLOR]
Range("A3").Select 
'Application.CutCopyMode = False
Selection.ClearContents
End If

If Sheets(1).Range("AA3").Value = "S1" Then
Fred ("A2")    [COLOR="Lime"]'appel 3em macro avec argument[/COLOR]
End If

If Sheets(1).Range("AA3").Value = "S2" Then
Fred ("A3")    [COLOR="Lime"]'appel 3em macro avec argument[/COLOR]
End If

If Sheets(1).Range("AA3").Value = "S3" Then
Fred ("A4")      [COLOR="Lime"]'appel 3em macro avec argument[/COLOR]
End If

blablabla

[COLOR="green"]'If Sheets(1).Range("AA3").Value = "" And "S1" And "S2" And "S3" And "S4" And "S5" And "S6" And "S7" And "S8" And "S9" And "S10" And "S11" And "S12" Then
'CreateObject("WScript.Shell").Popup "Repertoire non identifier", 1, "Fred"
'End If[/COLOR] ' [COLOR="Red"]cela j'aimerai bien l'intergrer mais ca ne marche pas..[/COLOR]
    erreur_macro1 = erreur_SaveAs
    If erreur_SaveAs <> "" Then
    CreateObject("WScript.Shell").Popup erreur_SaveAs, 2, "SaveAs erreur_SaveAs"[COLOR="Blue"] 'pour verifier si l' argument remonte[/COLOR]
    End If
End Sub

la 3em macro dans un autre module de perso.xls

Public Sub Fred(MaCellule As String)
    Dim Fichier, Fichier_Origine, Path, [COLOR="Magenta"]perso,Erreur_Fred[/COLOR]
    
'    Erreur_Fred = ""
      
    [COLOR="magenta"]perso = ActiveWorkbook.Name[/COLOR]
       
    Fichier_Origine = ActiveWorkbook.FullName
    Fichier = [COLOR="magenta"]Workbooks(perso).[/COLOR]Sheets(1).Range("A3").Value & ".xls"
    Path = [COLOR="magenta"]Workbooks("Personl.xls").[/COLOR]Sheets("Destination").Range(MaCellule).Value
    
    If Path = "" Then
        [COLOR="Red"]Erreur_Fred = "Aucun Repertoire de mémoriser"[/COLOR]
        Else
    If Sheets(1).Range("A3").Value = "" Then
        [COLOR="red"]Erreur_Fred = "Aucun nom"[/COLOR]
    Else
        If Fichier = Fichier_Origine Then
            [COLOR="red"]Erreur_Fred = "Meme nom, aucune action"[/COLOR]
        Else
            If Dir(Path & "\" & Fichier) = "" Then
            Workbooks(perso).SaveAs Filename:=Path & Fichier
            'Kill Fichier_Origine
             Else
            [COLOR="red"]Erreur_Fred = "le fichier existe deja"[/COLOR]
            End If
         End If
    End If
End If
[COLOR="red"]If Erreur_Fred <> "" Then
CreateObject("WScript.Shell").Popup Erreur_Fred, 2, "Fred gestion des erreurs"
End If[/COLOR]

[COLOR="RoyalBlue"]erreur_SaveAs = Erreur_Fred[/COLOR]

End Sub

 

[PascalXLD]

Re : racourcir code VBA avec goto

re

Bon pour utiliser tes variables dans 2 procédures différentes comme tu le fais il faut les déclarer public dans un module en début de celui-ci avant tout code

exemple

Public erreur_SaveAs as string
Public Sub Save_as()
ton code
end sub

public sub fred....
Bonne journée

 

[fredh]

Re : racourcir code VBA avec goto

Bonjour pascal76, le fil

Pascal76 je vais tester cela chez moi sur excell2003/XP puis Lundi sur excel97/Nt4.
Une question quand meme si je declare Public erreur_SaveAs as string dans un module en fin de liste dans l'explorateur les modules de debut vont il reconaitre la variable ? de meme pour des module d'autres fichiers ?

Merci et bon courage pour tes aplis...

@+

 

[PascalXLD]

Re : racourcir code VBA avec goto

Re

Une variable déclarée public est reconnue par tous les modules et feuille workbook de ton appli

Perso sur de grosses applis je me fais même un module qui me sert à déclarer mes variables public.

Pour l'autre question faudrait plus de précision

Bon WE

 

[ChTi160]

Re : racourcir code VBA avec goto

Salut fredh
Bonsoir Mytå ,Pascal, le Fil
je me suis permis de modifier le code de Mytå (Il ne m'en voudra pas j'espère)

Private Sub UserForm_Initialize ()
     Dim Nb As Integer, Ctrl As Control
        Nb = 0
  For Each Ctrl In Me.Controls
      If TypeName(Ctrl) = "CommandButton" Then
          Nb = Nb + 1
           ReDim Preserve Bouton(1 To Nb)
             Set Bouton(Nb).GroupeBouton = Ctrl
               [COLOR=blue]Ctrl.Tag = "A" & Nb '[COLOR=green]jajoute en Tag la référence[/COLOR]
[/COLOR]
      End If
  Next Ctrl
 
  End Sub

Private Sub GroupeBouton_click()
     With GroupeBouton
           [COLOR=blue]toto (GroupeBouton.Tag) '[COLOR=green]j'utilise le Tag comme référence[/COLOR]
[/COLOR]
     End With
  End Sub

bonne fin de Soirée

 

[Mytå]

Re : racourcir code VBA avec goto

Salut le Forum

Merci ChTi160, je n'y avait pas pensé à celle la.

Salutation Mytå

P.S. Petite rectification

IL ne m'en voudra pas j'espère

 

[fredh]

Re : racourcir code VBA avec goto

Bonsoir Pasal76, myta, chti160, le fil

Voila le code presque final que j'utilise.
dans le fichier Personl.xls avec feuille masquer et placer dans Excelstart, je stocke mes "repertoire favoris" ainsi que des chemins de fichier utile.

Je declare mes variable public dans un module:

Public Erreur [COLOR=orange]As String[/COLOR], Param [COLOR=orange]As String[/COLOR], Desti As String [COLOR=orange]'corriger par Pascal76[/COLOR]

Je peut lancer mes procedure par deux bouton de commande (dans la barre d'outil).

Sub Macro_1()
    Param = "macro_1"
    Save_as
End Sub
 
Sub Macro_2()
    Param = "macro_2"
    Save_as
End Sub

Puis le code principale :

Sub Save_as()
Desti = Sheets(1).Range("AA3").Value
 
If Param = "macro_1" And Desti = "" Then
    Fred ("C2")
    If Erreur = "" Then
    Range("A3").Select
    'Application.CutCopyMode = False
    Selection.ClearContents
    End If
End If
 
If Param = "macro_1" And Desti <> "" Then
    Erreur = "[COLOR=seagreen]Pour la Macro 1 la celulle 'AA3' doit etre vide[/COLOR]"
    Sheets(1).Select
    Range("AA3").Select
End If
 
If Param = "macro_2" And Desti = "S1" Then
Fred ("C3")
End If
If Param = "macro_2" And Desti = "S2" Then
Fred ("C4")
End If
If Param = "macro_2" And Desti = "S3" Then
Fred ("C5")
End If
If Param = "macro_2" And Desti = "S4" Then
Fred ("C6")
End If
If Param = "macro_2" And Desti = "S5" Then
Fred ("C7")
End If
If Param = "macro_2" And Desti = "S6" Then
Fred ("C8")
End If
If Param = "macro_2" And Desti = "S7" Then
Fred ("C9")
End If
If Param = "macro_2" And Desti = "S8" Then
Fred ("C10")
End If
If Param = "macro_2" And Desti = "S9" Then
Fred ("C11")
End If
If Param = "macro_2" And Desti = "S10" Then
Fred ("C12")
End If
If Param = "macro_2" And Desti = "S11" Then
Fred ("C13")
End If
If Param = "macro_2" And Desti = "S12" Then
Fred ("C14")
End If
If Desti <> "" And Desti <> "S1" And Desti <> "S2" And Desti <> "S3" _
    And Desti <> "S4" And Desti <> "S5" And Desti <> "S6" And Desti <> "S7" And _
    Desti <> "S8" And Desti <> "S9" And Desti <> "S10" And Desti <> "S11" And _
    Desti <> "S12" Then
    Erreur = "[COLOR=seagreen]Répèrtoire non identifié[/COLOR]"
    Sheets(1).Select
    Range("AA3").Select
End If
 
If Param = "macro_2" And Desti = "" Then
    Erreur = "[COLOR=seagreen]Pour la Macro 2 la celulle 'AA3' doit contenir une destination[/COLOR]"
    Sheets(1).Select
    Range("AA3").Select
End If
 
If Erreur <> "" Then
CreateObject("WScript.Shell").Popup Erreur & vbLf & vbLf & vbLf & vbLf & _
"Voici le racourcis a rentrez dans la celulle 'AA3' pour les destinations :" & vbLf & vbLf & _
"       -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C2")).Value & vbLf & _
"S1  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C3")).Value & vbLf & _
"S2  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C4")).Value & vbLf & _
"S3  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C5")).Value & vbLf & _
"S4  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C6")).Value & vbLf & _
"S5  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C7")).Value & vbLf & _
"S6  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C8")).Value & vbLf & _
"S7  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C9")).Value & vbLf & _
"S8  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C10")).Value & vbLf & _
"S9  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C11")).Value & vbLf & _
"S10  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C12")).Value & vbLf & _
"S11  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C13")).Value & vbLf & _
"S12  -->  " & Workbooks("Personl.xls").Sheets("destination").Range(("C14")).Value & vbLf _
, 10, "Gestion des erreurs"
End If
    Application.DisplayAlerts = True
   [COLOR=seagreen]Erreur = ""[/COLOR]
End Sub

Sub Fred(MaCellule As String)
Dim Nom_Desti[COLOR=orange] As String[/COLOR], Nom_Orig[COLOR=#ffa500] As String[/COLOR], Fichier_Desti[COLOR=#ffa500] As String[/COLOR], Fichier_Orig[COLOR=#ffa500] As String[/COLOR]
Dim Path_Desti[COLOR=#ffa500] As String[/COLOR], Path_Orig[COLOR=#ffa500] As String[/COLOR], Fichier_Maitre[COLOR=#ffa500] As String[/COLOR], Rep_Muster As String
'[COLOR=#ffa500] Coriger par Pascal76[/COLOR]
 
Nom_Orig = ActiveWorkbook.Name
Path_Orig = ActiveWorkbook.Path & "\"
Fichier_Orig = ActiveWorkbook.FullName
 
Nom_Desti = Workbooks(Nom_Orig).Sheets(1).Range("A3").Value & ".xls"
Path_Desti = Workbooks("Personl.xls").Sheets("Destination").Range(MaCellule).Value
Fichier_Desti = Path_Desti & Nom_Desti
 
Fichier_Maitre = Workbooks("Personl.xls").Sheets("Destination").Range("D2").Value
Rep_Muster = Workbooks("Personl.xls").Sheets("Destination").Range("D3").Value
 
If Path_Desti = "" Then
    Erreur = "[COLOR=seagreen]Aucun répèrtoire de mémoriser[/COLOR]"
Else
    If Sheets(1).Range("A3").Value = "" Then
        Erreur = "[COLOR=seagreen]Aucun nom en celulle 'A3'[/COLOR]"
    Else
        If Fichier_Desti = Fichier_Orig Or Dir(Fichier_Desti) <> "" Then
             Erreur = "[COLOR=seagreen]Le fichier existe déja dans le répèrtoire de déstination ...[/COLOR]"
        Else
            If Param = "macro_1" Then
                Macro_1.Macro_11
            End If
        Workbooks(Nom_Orig).SaveAs Filename:=Fichier_Desti
        CreateObject("WScript.Shell").Popup "Nouveau fichier créer dans :" & _
        vbLf & vbLf & Path_Desti & vbLf & vbLf & vbLf & "Nom du fichier :  " & _
        Nom_Desti & vbLf, 3, "Fred"
        Workbooks("Personl.xls").Sheets("Neue_Dateien").Range("A2") = _
Fichier_Orig [COLOR=red]'ici il faudrait que je rajoute cela dans la premiere celulle libre en colonne A[/COLOR]
        Workbooks("Personl.xls").Sheets("Neue_Dateien").Range("C2") =  _
Fichier_Desti [COLOR=#ff0000]'ici il faudrait que je rajoute cela en ofset de la celulle A+ 2 c'est a dire dans la colonne C et dans la ligne de la celulle active[/COLOR]
            If Param = "macro_2" And Fichier_Orig <> Fichier_Maitre And _
Path_Orig <> Rep_Muster Then
                Kill Fichier_Orig
                Workbooks("Personl.xls").Sheets("Neue_Dateien").Range("B2") _
 = "Gelöscht" [COLOR=#ff0000]'ici il faudrait que je rajoute cela en ofset de la celulle A+ 1 c'est a dire dans la colonne B et dans la ligne de la celulle active[/COLOR]
                CreateObject("WScript.Shell").Popup "Ancien fichier effacer :" & _
                vbLf & vbLf & Fichier_Orig & vbLf & vbLf, 5, "Fred"
            End If
        End If
    End If
End If
Sheets(1).Select
Range("A3").Select
End Sub

Si quelqu'un a le courage de jeter un oeil et de m'aporter ces remarques ca serait vraiment bien, d'autant que j'ai encore un petit soucis pour mon "journal" (voir ligne en rouge).
N'hesiter pas a dire que c'est du boulot d'amateur, je suis amateur...
Un grand Merci aux courageux qui apporteront leur pierre a ma hutte...