Comment simplifier automatiser ce code VBA?

Le
anthooooony Hors ligne
Bonjour,

Je suis débutant en VBA, je voulais déjà remercié MichD d'avoir répondu à un post il y a quelque jour ce qui m'a beaucoup aidé à avancé.

Je cherche une piste pour simplifier mon code, et à le rendre plus malléable quant aux modifications qui peuvent être faites.

Je dois diffuser des données à des agences, j'ai 180 onglets, et 60 agences dans un même fichier xlsx.

Le code ci dessous marche pour une agence déterminée, avec des onglets déterminées et l'enregistrement à un endroit déterminé.

Sélectionner les onglets que je souhaite
L'enregistrer à un nom spécifique au format .xlsx
L'enregistrer à un endroit donné
l'enregistrer au format pdf

Mais si je dois rajouter le reste des agences? avec des nouveaux onglets comment vais je faire? recopier tel quel la formule et changer la destination etc, mais avec 180 onglets et 60 agences la formule va faire des kilometres !
Ni a t-il pas une solution moins longue?
Est il possible de lui mettre dans une feuille
Colonne A: Nom des onglet
Colonne B: Nom du fichier
Colonne C: l'endroit ou l'enregistré et que la macro agisse en fonction de ces infos, le code serait beaucoup plus court.

Avez vous un piste, un conseil?
Merci d'avance !!

Sub test()
Application.DisplayAlerts = False
Sheets(Array("Agence ALSACE", "Agence ALSACE (2)", "Agence ALSACE (3)")).Copy
ActiveWorkbook.SaveAs "N:LitigesTest AutomatLitiges Agence ALSACE.xlsx"

Dim i As Integer
With ActiveWorkbook
For i = 1 To Sheets.Count
With Sheets(i).Cells
.Columns.AutoFit
.Rows.AutoFit
.Cells.Locked = False
.Range("B2").Locked = True
End With
Next i

ActiveWorkbook.Worksheets.Select
For Each xworksheet In ActiveWorkbook.Worksheets
xworksheet.Select
Range("F:F").ColumnWidth = 170
Range("F:F").WrapText = True

With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintArea = "$A$4:$H$51"
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0)
.FitToPagesWide = 1
.FitToPagesTall = 1
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.Orientation = xlLandscape
.Zoom = False
End With
Next xworksheet

'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="N:LitigesTest AutomatAgence ALSACE.pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:úlse, _
OpenAfterPublish:úlse
MsgBox "Fiche crée et database mise à jour"
End With

ActiveWorkbook.Close False

End Sub
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
isabelle
Le #24219561
bonjour anthooooony,


Sub test()
Dim i As Integer

With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

Sheets(Array("Agence ALSACE", "Agence ALSACE (2)", "Agence ALSACE (3)")).Copy
ActiveWorkbook.SaveAs "N:LitigesTest AutomatLitiges Agence ALSACE.xlsx"


With ActiveWorkbook

For i = 1 To .Sheets.Count
With .Sheets(i)

With .Cells
.Columns.AutoFit
.Rows.AutoFit
.Cells.Locked = False
.Range("B2").Locked = True
End With


.Range("F:F").ColumnWidth = 170
.Range("F:F").WrapText = True

With .PageSetup
.PrintTitleRows = "$1:$4"
.PrintArea = "$A$4:$H$51"
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0)
.FitToPagesWide = 1
.FitToPagesTall = 1
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.Orientation = xlLandscape
.Zoom = False
End With

End With
Next i

'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="N:LitigesTest AutomatAgence ALSACE.pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:úlse, _
OpenAfterPublish:úlse

End With

MsgBox "Fiche crée et database mise à jour"
ActiveWorkbook.Close False

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub


--
isabelle
Publicité
Poster une réponse
Anonyme