Pour une amélioration

[nimbus le truand]

Bonjour à vous tous !!

Je ne pratique pas souvent les forums mais aujourd'hui j’en ressens le besoin !! Je suis en stage et je crée une automatisation pour un fichier EXCEL avec VBA. Si je vous écris c’est pour avoir des commentaires sur mon code, voir des améliorations. Alors n’hésitez pas, CRITIQUEZ !!!

Explication de mon travail :
Un logiciel que nous allons appeler PB à la possibilité d’exporter en fichier Excel, ce fichier contient seulement une feuille avec un tableau (les noms des champs sont absents, il n’y a rien que les valeurs). Je copie donc ce tableau vers une fichier qui contient la macro ci-dessous qu’y c’est exécuté à ma demande ; et je le remet en forme avant de le sauvegarder sous un autre nom.
En résumer, j’ouvre le fichier contenant la macro puis je l’exécute. La macro récupère le tableau exporté et le remet en forme puis me propose de l’enregistrer sous un autre nom.

Voilà, j’espère avoir été assez clair, si vous avez des questions n’hésitez pas, je serai très content de vous répondre.

Merci d’avance pour toutes vos remarques que vous pourrez me donner.

Nimbus le Truand

P.S : voilà le code que j’ai créé et qu’il faudrait optimiser si possible.

Sub RemplissageTableau()
'
' RemplissageTableau Macro
'
' Macro enregistrée le 14/06/2004
' permettant le remplissage du tableau de 'Devis' par les valeurs exportées de PB sous la forme Excel

'**************** Travail sur le fichier d'exportation de PB ****************
' Définit le répertoire courant du fichier tampon (exportation PB)
ChDir "D:\Mes Documents"
' Ouvre le fichier tampon (exportation PB)
FileToOpen = Application.GetOpenFilename("Fichier Excel (*.xls), *.xls")
If FileToOpen = False Then Exit Sub
ThisWorkbook.FollowHyperlink FileToOpen
' Mise en forme "date de détection" de jj/mm/yyyy vers dd-mmmm-yy
Columns("J:J").Select
Selection.NumberFormat = "[$-40C]d-mmm-yy;@"
' Active le fichier tampon et copie la sélection
Selection.CurrentRegion.Select
Selection.Copy

'********************* Travail sur le fichier Devis Prototype *********************
' Active le fichier Devis (j’aimerai activer le fichier avec comme variable le fichier que j’ai ouvert contenant la macro VBA)
Windows("Issy devis.xls").Activate 'A changer en fonction du fichier concerné
' Colle la sélection
Range("A19").Select
ActiveSheet.Paste
' Remise en forme des données
Application.CutCopyMode = False
With Selection.Font
.Name = "Comic Sans MS"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
' Suppression des colonnes inintéressantes pour le tableau Devis
Columns("L").Select
Selection.ClearContents
' Création des bordures du tableau
Range("A19").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
' Suppression de la ligne entre les titres et le tableau Devis
Rows("18:18").Select
Selection.Delete Shift:=xlUp

'******************* Sauvegarde le fichier Devis pour le Client *******************
' Définit le répertoire courant des fichiers clients
ChDir "D:\Mes Documents"
' Sauvegarde le fichier sous le nom courant du client
Application.Dialogs(xlDialogSaveAs).Show

' Change le numéro du Devis (est le même que le numéro du fichier)
Dim NumDevis As String

NumDevis = InputBox("Quel est le numéro du Devis ?")
If NumDevis = "" Then Exit Sub
Range("C2:C6").Select
ActiveCell.FormulaR1C1 = "DEVIS" & Chr(10) & "n° 0" & NumDevis
Sheets("issy devis 0").Name = "issy devis 0" & NumDevis

' Se met sur la date du devis pour modification
Range("C9").Select ‘ combinaison de ctrl + ; pour mettre la date du jour

End Sub

 

[yeahou]

Bonjour Nimbus le truand, quel pseudo !

Voici un exemple de code un peu plus optimisé. L'affichage écran est désactivé temporairement pour gagner en rapidité. J'ai éliminé les sélections qui ne servent à rien dans ce cas car la sélection est une des opérations les plus lentes. J'établis une référence au départ avec Set Feuil_Ori = ThisWorkbook.Sheets(1) et je m'en sers dans le reste du code en travaillant en relatif. N'ayant pas de fichiers exemple, je n'ai pas pu le tester.

Cordialement, A+

Sub RemplissageTableau()

'désactivation de l'affichage écran pour + de rapidité
Application.ScreenUpdating = False
'Déclaration du variant feuille de travail
Dim Feuil_Ori
'positionnement de la feuille de travail sur le classeur d'origine de la macro, feuille 1
Set Feuil_Ori = ThisWorkbook.Sheets(1) 'feuille de travail à préciser

' RemplissageTableau Macro
'
' Macro enregistrée le 14/06/2004
' permettant le remplissage du tableau de 'Devis' par les valeurs exportées de PB sous la forme Excel

'**************** Travail sur le fichier d'exportation de PB ****************
' Définit le répertoire courant du fichier tampon (exportation PB)
ChDir "D:\Mes Documents"
' Ouvre le fichier tampon (exportation PB)
FileToOpen = Application.GetOpenFilename("Fichier Excel (*.xls), *.xls")

'Condition d 'exécution
If Not (FileToOpen = False) Then
ThisWorkbook.FollowHyperlink FileToOpen
' Mise en forme "date de détection" de jj/mm/yyyy vers dd-mmmm-yy
With Columns("J:J")
.NumberFormat = "[$-40C]d-mmm-yy;@"
' copie les données dans la feuille de travail
.CurrentRegion.Copy Destination:=Feuil_Ori.[A19]
End With
Application.CutCopyMode = False
'********************* Travail sur le fichier Devis Prototype *********************
' Remise en forme des données
With Feuil_Ori
' Création des bordures du tableau
With .[A19].CurrentRegion
With .Font
.Name = "Comic Sans MS"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
' Suppression des colonnes inintéressantes pour le tableau Devis
'si peut être placée aprés with feuil_ori alors
'.Columns("L").ClearContents
Feuil_Ori.Columns("L").ClearContents

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
' Suppression de la ligne entre les titres et le tableau Devis
.Rows("18:18").Delete Shift:=xlUp

'******************* Sauvegarde le fichier Devis pour le Client *******************
' Définit le répertoire courant des fichiers clients
ChDir "D:\Mes Documents"
' Sauvegarde le fichier sous le nom courant du client
Application.Dialogs(xlDialogSaveAs).Show

' Change le numéro du Devis (est le même que le numéro du fichier)
Dim NumDevis As String

NumDevis = InputBox("Quel est le numéro du Devis ?")
If NumDevis <> "" Then
.[C2].FormulaR1C1 = "DEVIS" & Chr(10) & "n° 0" & NumDevis
'si Sheets("issy devis 0") est thisworkbook.sheets(1) alors activer le code suivant plutôt que l'autre
'.Name = "issy devis 0" & NumDevis
ThisWorkbook.Sheets("issy devis 0").Name = "issy devis 0" & NumDevis

' Se met sur la date du devis pour modification
.[C9].Value = Now() ' met la date du jour
End If
End With
End If
End Sub

 

[yeahou]

Re Bonjour

Et voila, j'ai oublié un
Thisworkbook.activate
devant
Application.Dialogs(xlDialogSaveAs).Show
pour sélectionner le fichier d'origine de la macro avant enregistrement.
Désolé

A+

 

[Michel_M]

Bonjour Nimbus, yeahou et le forum

nimbus,

yeahou a fait le principal.

Tu peux encore alléger ton code pour la mise en forme du tableau (sans pièce jointe, il te faudra peut être adapter à ton pb...)

pour réaliser les bordures et la police, tu peux écrire:

With Range("A19").CurrentRegion
.Borders.Weight = xlThin
.BorderAround (xlDouble)
With .Font
.Name = "Comic Sans MS"
.Size = 10
End With
End With

Ce pour éliminer les paramètres facultatifs inutiles venus de l'enregistreur de macro: ne pas "élaguer " est très mal vu par un jury de stage

Bon courage pour ton rapport de stage

Michel

 

[nimbus le truand]

Yahoo, merci beaucoup les gars, grâce à vous ça marche du tonnerre

Désolé de répondre si tardivement mais j’ai passé mon week-end et la fête de la musique loin de mon ordinateur donc pas d’Internet… Mais c’est fini, me revoilà !!

Le code est maintenant beaucoup plus rapide, merci yeahou. Pour ce qui est de mon stage, Michel, avec ça y’a pas de problème.

Bon ! Mais retournons à mes moutons. Je dois faire de ce code un code portatif !! Hein ! Quoi ! C’est tout simple, je doit importer cette macro sur environ une dizaine de fichiers similaires et je n’ai pas très envie de me répéter des manipulations systématiques pour reformater mon code au nouveau fichier. C’est pourquoi j’insère une ‘ImputBox’. Et je voudrai utiliser son résultat à plusieurs endroits ; explication :

' Numéro du Devis
Dim NumDevis As String
NumDevis = InputBox("Quel est le numéro du Devis ?")
If Not NumDevis = "" Then .[C2].FormulaR1C1 = "DEVIS" & Chr(10) & "n° 0" & NumDevis
.Name = "issy devis 0" & NumDevis

Dans cet exemple, je voudrais récupérer ce qui se trouve en [C2] et y rajouter le ‘NumDevis’ à la fin, pareil pour le nom de la feuille. Comme ça, ‘issy devis 0’ pourra être ‘toto en banane’, je rajouterai bien le numéro du Devis derrière sans me préoccuper de ce qu’il y a écrit, pareil pour la cellule [C2].

Et dernier truc, comme je récupère le numéro du Devis, je veux le rajouter à la fin du nom proposé dans la fenêtre ‘enregistrer sous’, comme ça y’a rien qu’à presser la touche Enter.

' Sauvegarde le fichier sous le nom courant du client
ThisWorkbook.Activate
Application.Dialogs(xlDialogSaveAs).Show
‘ Propose le nom courant du fichier ouvert auquel il faut rajouter le numéro du Devis

Voilà, avec tous ça normalement le code ne fera plus référence à des choses écrites (seulement des emplacements, mais ça, ça ne bougent pas entre les différents fichiers) et j’aurai un code bien portatif et facilement implantable.

Je voulais encore vous remercier pour cette aide si précieuse que vous m’apportez. Merci

Nimbus

 

[nimbus le truand]

Salut à tous,

Je viens de finir ce projet et je vous remercie encore une bonne fois, c’est aussi grâce à l’invention des forums… belle chose quand même.
Voilà, donc mon programme est bien portatif et il marche du tonnerre. Ce n’était pas facile mais avec une équipe forum, on peut tout faire !!

Encore merci

Nimbus

 

[Lapou]

Salut Nimbus

tu pourrais pas nous faire profiter de ton projet en nous l'envoyant ;-) ?

Tchao

 

[nimbus le truand]

Salut Lapou,

Yes, je peux. Si vous avez des améliorations à y apporter et des tests supplémentaires pour éviter les bugs et erreurs, je suis preneur à 1000%

A+

P.S: code à mettre au fichier Excel (pièce jointe):

Dim NomClient
Sub RemplissageTableau()
'
' RemplissageTableau Macro
'
' permettant le remplissage du tableau de 'Attachement' par les valeurs exportées de PictBase sous la forme Excel

' Désactivation de l'affichage écran pour plus de rapidité
Application.ScreenUpdating = False
' Déclaration du variant feuille de travail
Dim Feuil_Ori
' Positionnement de la feuille de travail sur le classeur d'origine de la macro, feuille 1
Set Feuil_Ori = ThisWorkbook.Sheets(1) 'feuille de travail à préciser


'**************** Travail sur le fichier d'exportation de PictBase ****************

' Définit le répertoire courant du fichier tampon (exportation PictBase)
TempDrive = "Z"
ThePath = "Z:\Exploitation"
ChDrive TempDrive
ChDir ThePath

' Ouvre le fichier tampon (exportation PictBase)
FileToOpen = Application.GetOpenFilename("Fichier Excel (*.xls), *.xls")
' Condition d'exécution
If Not (FileToOpen = False) Then ThisWorkbook.FollowHyperlink FileToOpen _
Else Exit Sub
' Récupération du Nom du Client & Suppression de la colonne Client
NomClient = Range("A2")
With Columns("A:A")
.ClearContents
End With
' Mise en forme "date de détection" et "date d'intervention" de jj/mm/yyyy vers dd-mmmm-yy
With Columns("K:K")
.NumberFormat = "[$-40C]d-mmm-yy;@"
With Columns("N:N")
.NumberFormat = "[$-40C]d-mmm-yy;@"
End With
'Tri les données selon les dates d'Intervention (tableau avec titre de colonne)
Cells.Select
Selection.Sort Key1:=Range("N2"), Order1:=xlAscending, _
Key2:=Range("D2"), Order2:=xlAscending, _
Key3:=Range("E2"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

' Copie les données dans la feuille de travail
.CurrentRegion.Copy Destination:=Feuil_Ori.[A9]
End With
Application.CutCopyMode = False


'********************* Travail sur le fichier Attachement Prototype *********************

' Active le fichier Attachement
With Feuil_Ori
' Suppression de la ligne entre les titres et le tableau
.Rows("9:9").Delete Shift:=xlUp
' Remise en forme des données
With .[A8].CurrentRegion
With .Font
.Name = "Comic Sans MS"
.Size = 10
End With
' Création des bordures du tableau
With .Borders(xlEdgeLeft)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlEdgeTop)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlEdgeRight)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
' Nom du Client affiché sur l'attachement
.[L2].Value = NomClient
' Date de début et de fin des interventions
.[L3].FormulaR1C1 = "=MIN(C[1])"
.[L4].FormulaR1C1 = "=MAX(C[1])"
' Ajustement automatique des colonnes
.Columns.AutoFit
' Mise en page du document
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$8"
.PrintArea = "$A:$P"
End With


'******************* Sauvegarde le fichier Attachement pour le Client *******************

Dim NomFichier As String, NomFichierFinal As String
Dim NumDevis As String

' Définit le répertoire courant des fichiers clients
TempDrive = "Y"
ThePath = "Y:\"
ChDrive TempDrive
ChDir ThePath

' Sauvegarde le fichier sous le nom courant du client
ThisWorkbook.Activate
' Récupère le numéro du Devis (est le même que le numéro du fichier)
NumDevis = Application.InputBox(Prompt:="Quel est le numéro correspondant au Devis (entier seulement) ?")
' Récupère le nom du fichier sans l'extension
NomFichier = ThisWorkbook.Name 'Récupère le nom
If InStr(1, NomFichier, ".", 1) > 0 Then NomFichier = Left(NomFichier, _
InStr(1, NomFichier, ".", 1) - 1) 'Enlève toute extension présente
' Insère le numéro correspondant au Devis
If Not NumDevis = "" Then .[L5].Value = "N° " & NumDevis

' Sauvegarde le fichier avec le numéro sous le forme : "NomFichier NumDevis.xls ""
NomFichierFinal = Application.GetSaveAsFilename(NomClient & " " & NomFichier & " " & NumDevis & ".xls", _
FileFilter:="Fichiers Excel (*.xls),*.xls", Title:="Enregistrement") 'dialogue enregistrer sous
If Not (NomFichierFinal = "Faux") Then ThisWorkbook.SaveAs Filename:=NomFichierFinal _
Else MsgBox "Annulation, fichier non enregistré ", vbInformation 'sauvegarde le fichier si pas d'annulation

End With
End Sub

 

[Lapou]

Merci ;-)

 

[Yeahou]

Bonjour Nimbus, tout le monde

vite fait:

j'ai spécifié feuil_ori en worksheet

j'ai enlevé
les with non necessaires
la sélection avant tri

j'ai modifié la définition du nom de fichier pour éviter le problème d'un point dans le nom dont on avait déja parlé

Cordialement, A+

Dim NomClient
Sub RemplissageTableau()
'
' RemplissageTableau Macro
'
' permettant le remplissage du tableau de 'Attachement' par les valeurs exportées de PictBase sous la forme Excel

' Désactivation de l'affichage écran pour plus de rapidité
Application.ScreenUpdating = False
' Déclaration du variant feuille de travail
Dim Feuil_Ori As Worksheet
' Positionnement de la feuille de travail sur le classeur d'origine de la macro, feuille 1
Set Feuil_Ori = ThisWorkbook.Sheets(1) 'feuille de travail à préciser


'**************** Travail sur le fichier d'exportation de PictBase ****************

' Définit le répertoire courant du fichier tampon (exportation PictBase)
TempDrive = "Z"
ThePath = "Z:\Exploitation"
ChDrive TempDrive
ChDir ThePath

' Ouvre le fichier tampon (exportation PictBase)
FileToOpen = Application.GetOpenFilename("Fichier Excel (*.xls), *.xls")
' Condition d'exécution
If Not (FileToOpen = False) Then ThisWorkbook.FollowHyperlink FileToOpen Else Exit Sub
' Récupération du Nom du Client & Suppression de la colonne Client
NomClient = Range("A2")
Columns("A:A").ClearContents
' Mise en forme "date de détection" et "date d'intervention" de jj/mm/yyyy vers dd-mmmm-yy
Columns("K:K").NumberFormat = "[$-40C]d-mmm-yy;@"
Columns("N:N").NumberFormat = "[$-40C]d-mmm-yy;@"
'Tri les données selon les dates d'Intervention (tableau avec titre de colonne)
Cells.Sort Key1:=Range("N2"), Order1:=xlAscending, _
Key2:=Range("D2"), Order2:=xlAscending, _
Key3:=Range("E2"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

' Copie les données dans la feuille de travail
Columns("K:K").CurrentRegion.Copy Destination:=Feuil_Ori.Range("A9")
Application.CutCopyMode = False


'********************* Travail sur le fichier Attachement Prototype *********************

' Active le fichier Attachement
With Feuil_Ori
' Suppression de la ligne entre les titres et le tableau
.Rows("9:9").Delete Shift:=xlUp
' Remise en forme des données
With .[A8].CurrentRegion
With .Font
.Name = "Comic Sans MS"
.Size = 10
End With
' Création des bordures du tableau
With .Borders(xlEdgeLeft)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlEdgeTop)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlEdgeRight)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
' Nom du Client affiché sur l'attachement
.[L2].Value = NomClient
' Date de début et de fin des interventions
.[L3].FormulaR1C1 = "=MIN(C[1])"
.[L4].FormulaR1C1 = "=MAX(C[1])"
' Ajustement automatique des colonnes
.Columns.AutoFit
' Mise en page du document
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$8"
.PrintArea = "$A:$P"
End With


'******************* Sauvegarde le fichier Attachement pour le Client *******************

Dim nomfichier As String, NomFichierFinal As String
Dim NumDevis As String

' Définit le répertoire courant des fichiers clients
TempDrive = "Y"
ThePath = "Y:\"
ChDrive TempDrive
ChDir ThePath

' Sauvegarde le fichier sous le nom courant du client
ThisWorkbook.Activate
' Récupère le numéro du Devis (est le même que le numéro du fichier)
NumDevis = Application.InputBox(Prompt:="Quel est le numéro correspondant au Devis (entier seulement) ?")
' Récupère le nom du fichier sans l'extension
nomfichier = ThisWorkbook.Name 'Récupère le nom
If InStrRev(nomfichier, ".", -1, 1) > 0 Then nomfichier = Left(nomfichier, _
InStrRev(nomfichier, ".", -1, 1) - 1) 'Enlève toute extension présente
' Insère le numéro correspondant au Devis
If Not NumDevis = "" Then .[L5].Value = "N° " & NumDevis
End With

' Sauvegarde le fichier avec le numéro sous le forme : "NomFichier NumDevis.xls ""
NomFichierFinal = Application.GetSaveAsFilename(NomClient & " " & nomfichier & " " & NumDevis & ".xls", _
FileFilter:="Fichiers Excel (*.xls),*.xls", Title:="Enregistrement") 'dialogue enregistrer sous
If Not (NomFichierFinal = "Faux") Then ThisWorkbook.SaveAs Filename:=NomFichierFinal _
Else MsgBox "Annulation, fichier non enregistré ", vbInformation 'sauvegarde le fichier si pas d'annulation

End Sub

 

[nimbus le truand]

Merci, C cool

Je te tien o courant de ce que ça donne !

Nimbus

 

[nimbus le truand]

Bon, C parfait

Merci beaucoup pour vos trouvailles, ça m’a fait grave avancer !!

J’ai mis d’autre post sur le forum, si vous les avez vu et que vous pouvez m’aider, ça serai une aide très précieuse pour moi,

Je vous remercie encore mille fois

Nimbus