Bouton VBA outlook pour ouvrir fichier
Morpheuuss
Messages postés
14
Statut
Membre
-
danielc0 Messages postés 2196 Date d'inscription Statut Membre Dernière intervention -
danielc0 Messages postés 2196 Date d'inscription Statut Membre Dernière intervention -
Bonjour,
J'ai un code VBA sur outlook qui me permet de lire différents rapports de mail et d'en faire des excels. Ensuite j'ai une fonction qui 'rassemble' tous ces excels en un seul, mais je voudrais également un bouton (dans la case E1 du fichier finale, sa position n'as pas d'importance pour l'instant) qui me permette d'ouvrir mon fichier de config lorsque je clique dessus. Ce fichier est utilisé pour la création de chaque excel.
Voici le code de la fonction qui rassemble tous les excels :
Sub Merge()
Dim sourceWorkbookNAS As Workbook
Dim sourceWorkbookAcronis As Workbook
Dim sourceWorkbookBootCatalog As Workbook
Dim sourceWorkbookPRTG As Workbook
Dim destinationWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim sourceFilePathNAS As String
Dim sourceFilePathAcronis As String
Dim sourceFilePathBootCatalog As String
Dim sourceFilePathPRTG As String
Dim destinationFilePath As String
Dim configFilePath As String
Dim sourceIndex As Integer
Dim destinationIndex As Integer
Dim lastRow As Long
Dim currentDate As Date
Dim formatdate As String
Dim ws As Worksheet
' Chemins des fichiers source et destination
formatdate = Format(Date, "dd_MM_yyyy")
sourceFilePathNAS = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_NAS.xlsx"
sourceFilePathAcronis = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_Acronis.xlsx"
sourceFilePathBootCatalog = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_BootCatalog.xlsx"
sourceFilePathPRTG = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_PRTG.xlsx"
destinationFilePath = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_consolidated_report.xlsx"
configFilePath = Environ("USERPROFILE") & "\Documents\mail\config.xlsx" ' Fichier Config pour gérer les noms des appareils
' Ouvrir les fichiers source et destination
Set sourceWorkbookNAS = Workbooks.Open(sourceFilePathNAS)
Set sourceWorkbookAcronis = Workbooks.Open(sourceFilePathAcronis)
Set sourceWorkbookBootCatalog = Workbooks.Open(sourceFilePathBootCatalog)
Set sourceWorkbookPRTG = Workbooks.Open(sourceFilePathPRTG)
Set destinationWorkbook = Workbooks.Open(destinationFilePath)
' Initialiser les indices pour les feuilles
sourceIndex = 1
destinationIndex = destinationWorkbook.Sheets.Count ' Commencer à la dernière feuille du destinationWorkbook
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' Transférer les données NAS dynamiquement
Do While sourceIndex <= sourceWorkbookNAS.Sheets.Count And destinationIndex >= 1
Set sourceSheet = sourceWorkbookNAS.Sheets(sourceIndex)
Set destinationSheet = destinationWorkbook.Sheets(destinationIndex)
' Trouver la dernière ligne avec des données dans la feuille source
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row
' Renommer la feuille de destination
RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date du NAS
' Transférer les données dynamiques
If lastRow >= 3 Then
With sourceSheet
' Fusionner A6 et B6, et les définir égal à A1 du fichier source (date)
With destinationSheet.Range("A6:B6")
.Merge ' Fusionner les cellules A6 et B6
.Value = sourceSheet.Range("A2").Value ' Prendre la valeur de A2 du fichier source
.Font.Size = 18 ' Taille de police 18
.Font.Bold = True ' Mettre en gras
.Font.Color = RGB(255, 255, 255) ' Couleur du texte en blanc
.Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB)
.HorizontalAlignment = xlCenter ' Centrer le texte horizontalement
.VerticalAlignment = xlCenter ' Centrer le texte verticalement
End With
' Mettre en place les en-têtes "Description" et "Statut"
destinationSheet.Range("A7").Value = "Description"
destinationSheet.Range("B7").Value = "Statut"
' Boucle dynamique pour transférer les données des NAS
Dim i As Long
For i = 3 To lastRow
destinationSheet.Cells(5 + i, 1).Value = .Cells(i, 1).Value ' Colonne A (Nom NAS)
destinationSheet.Cells(5 + i, 2).Value = .Cells(i, 2).Value ' Colonne B (Statut NAS)
Next i
End With
' Appliquer la couleur bleu clair aux cellules A8 jusqu'à la dernière ligne
With destinationSheet.Range("A7:B" & (5 + lastRow))
.Interior.Color = RGB(173, 216, 230) ' Bleu clair
End With
' Appliquer des bordures sur la plage A6:B(lastRow)
With destinationSheet.Range("A6:B" & (5 + lastRow)).Borders
.LineStyle = xlContinuous ' Style de ligne continu
.Weight = xlThin ' Épaisseur de la bordure (fine)
.ColorIndex = 0 ' Couleur noire par défaut
End With
' Appliquer la mise en forme conditionnelle pour le statut des NAS si nécessaire
ApplyConditionalFormattingNAS destinationSheet, lastRow
End If
' Passer à la feuille suivante dans source et précédente dans destination
sourceIndex = sourceIndex + 1
destinationIndex = destinationIndex - 1
Loop
' Réinitialiser les indices pour les feuilles Acronis
sourceIndex = 1
destinationIndex = destinationWorkbook.Sheets.Count ' Recommencer à la dernière feuille du destinationWorkbook
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' Transférer les données Acronis
Do While sourceIndex <= sourceWorkbookAcronis.Sheets.Count And destinationIndex >= 1
Set sourceSheet = sourceWorkbookAcronis.Sheets(sourceIndex)
Set destinationSheet = destinationWorkbook.Sheets(destinationIndex)
' Trouver la dernière ligne avec des données dans la feuille source
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row
' Renommer la feuille de destination
RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date d'Acronis
' Transférer les données dynamiques
If lastRow >= 3 Then
With sourceSheet
' Fusionner C6 et D6, et les définir égal à A2 et B2 du fichier source
With destinationSheet.Range("C6:D6")
.Merge ' Fusionner les cellules C6 et D6
.Value = sourceSheet.Range("A2").Value ' Prendre la valeur de A2 du fichier source
.Font.Size = 18 ' Taille de police 18
.Font.Bold = True ' Mettre en gras
.Font.Color = RGB(255, 255, 255) ' Couleur du texte en blanc
.Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB)
.HorizontalAlignment = xlCenter ' Centrer le texte horizontalement
.VerticalAlignment = xlCenter ' Centrer le texte verticalement
End With
destinationSheet.Range("C7").Value = "Description"
destinationSheet.Range("D7").Value = .Range("B2").Value
Dim j As Long
For j = 3 To lastRow
destinationSheet.Cells(5 + j, 3).Value = .Cells(j, 1).Value ' C column
destinationSheet.Cells(5 + j, 4).Value = .Cells(j, 2).Value ' D column
Next j
End With
' Appliquer la couleur bleu clair aux cellules C8 jusqu'à la dernière ligne
With destinationSheet.Range("C7:D" & (5 + lastRow))
.Interior.Color = RGB(173, 216, 230) ' Bleu clair
End With
' Appliquer des bordures sur la plage C7:D11
With destinationSheet.Range("C6:D" & (5 + lastRow)).Borders
.LineStyle = xlContinuous ' Style de ligne continu
.Weight = xlThin ' Épaisseur de la bordure (fine)
.ColorIndex = 0 ' Couleur noire par défaut
End With
' Appliquer la couleur verte ou rouge selon la valeur des cellules D12 et D13
ApplyConditionalFormattingAcronis destinationSheet, lastRow
End If
' Passer à la feuille suivante dans source et précédente dans destination
sourceIndex = sourceIndex + 1
destinationIndex = destinationIndex - 1
Loop
' Réinitialiser les indices pour les feuilles PRTG
sourceIndex = 1
destinationIndex = destinationWorkbook.Sheets.Count ' Recommencer à la dernière feuille du destinationWorkbook
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'Appliquer la couleur #18323F de E6:E10
For Each ws In destinationWorkbook.Sheets
ws.Range("E6:E10").Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB)
Next ws
' Transférer les données PRTG
Do While sourceIndex <= sourceWorkbookPRTG.Sheets.Count And destinationIndex >= 1
Set sourceSheet = sourceWorkbookPRTG.Sheets(sourceIndex)
Set destinationSheet = destinationWorkbook.Sheets(destinationIndex)
' Trouver la dernière ligne avec des données dans la feuille source
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row
' Renommer la feuille de destination
RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date de PRTG
With sourceSheet
' Fusionner F6 et G6
With destinationSheet.Range("F6:G6")
.Merge ' Fusionner les cellules F6 et G6
.Value = "PRTG"
.Font.Size = 18 ' Taille de police 18
.Font.Bold = True ' Mettre en gras
.Font.Color = RGB(255, 255, 255) ' Couleur du texte en blanc
.Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB)
.HorizontalAlignment = xlCenter ' Centrer le texte horizontalement
.VerticalAlignment = xlCenter ' Centrer le texte verticalement
End With
destinationSheet.Range("F7").Value = "Description"
destinationSheet.Range("G7").Value = .Range("B2").Value
Dim k As Long
For k = 3 To lastRow
destinationSheet.Cells(5 + k, 6).Value = .Cells(k, 1).Value ' F column
destinationSheet.Cells(5 + k, 7).Value = .Cells(k, 2).Value ' G column
Next k
' Appliquer la couleur bleu clair aux cellules F7 jusqu'à la dernière ligne
With destinationSheet.Range("F7:G" & (5 + lastRow))
.Interior.Color = RGB(173, 216, 230) ' Bleu clair
End With
' Appliquer des bordures sur la plage F7 jusqu'à la dernière ligne
With destinationSheet.Range("F6:G" & (5 + lastRow)).Borders
.LineStyle = xlContinuous ' Style de ligne continu
.Weight = xlThin ' Épaisseur de la bordure (fine)
.ColorIndex = 0 ' Couleur noire par défaut
End With
' Appliquer la couleur verte ou rouge selon la valeur des cellules G13 et au-delà
ApplyConditionalFormattingPRTG destinationSheet, lastRow
End With
' Passer à la feuille suivante dans source et précédente dans destination
sourceIndex = sourceIndex + 1
destinationIndex = destinationIndex - 1
Loop
' Réinitialiser les indices pour les feuilles Boot Catalog
sourceIndex = 1
destinationIndex = destinationWorkbook.Sheets.Count ' Recommencer à la dernière feuille du destinationWorkbook
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' Transférer les données Boot Catalog
Do While sourceIndex <= sourceWorkbookBootCatalog.Sheets.Count And destinationIndex >= 1
Set sourceSheet = sourceWorkbookBootCatalog.Sheets(sourceIndex)
Set destinationSheet = destinationWorkbook.Sheets(destinationIndex)
' Trouver la dernière ligne avec des données dans la feuille source
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row
' Renommer la feuille de destination
RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date de Boot Catalog
' Transférer les données dynamiques
If lastRow >= 3 Then
With sourceSheet
destinationSheet.Range("U11").Value = .Range("A1").Value
destinationSheet.Range("U12").Value = .Range("A2").Value
destinationSheet.Range("V12").Value = .Range("B2").Value
Dim l As Long
For l = 3 To lastRow
destinationSheet.Cells(10 + l, 21).Value = .Cells(l, 1).Value ' T column
destinationSheet.Cells(10 + l, 22).Value = .Cells(l, 2).Value ' U column
Next l
End With
' Appliquer la couleur bleu clair aux cellules T12 et U12
With destinationSheet.Range("U12:U" & (10 + lastRow))
.Interior.Color = RGB(173, 216, 230) ' Bleu clair
End With
End If
' Passer à la feuille suivante dans source et précédente dans destination
sourceIndex = sourceIndex + 1
destinationIndex = destinationIndex - 1
Loop
' Mettre en forme le fichier destination et ajouter un bouton à chaque feuille
For Each ws In destinationWorkbook.Sheets
' Centrage du contenu de la feuille
ws.Cells.HorizontalAlignment = xlCenter
ws.Cells.VerticalAlignment = xlCenter
ws.Columns.AutoFit
Next ws
' Enregistrer et fermer les classeurs
destinationWorkbook.Close SaveChanges:=True
sourceWorkbookNAS.Close SaveChanges:=False
sourceWorkbookAcronis.Close SaveChanges:=False
sourceWorkbookBootCatalog.Close SaveChanges:=False
sourceWorkbookPRTG.Close SaveChanges:=False
'wbConfig.Close SaveChanges:=True
'Supprimer les fichiers sources
Kill sourceFilePathNAS
Kill sourceFilePathAcronis
Kill sourceFilePathBootCatalog
Kill sourceFilePathPRTG
' Libérer la mémoire
Set sourceSheet = Nothing
Set sourceWorkbookNAS = Nothing
Set sourceWorkbookAcronis = Nothing
Set sourceWorkbookBootCatalog = Nothing
Set destinationSheet = Nothing
Set destinationWorkbook = Nothing
Set wbConfig = Nothing
End Sub
15 réponses
Résumé de la discussion
Le sujet porte sur l’ajout d’un bouton dans le fichier consolidé qui ouvre le fichier de configuration utilisé pour générer chaque Excel, en lien avec la procédure Merge. Des solutions préconisent de créer une macro publique OpenConfig dans un module standard et de lier un bouton via OnAction, afin d’éviter les limitations d’accès d’une macro privée ou d’un module feuille. Le principal écueil est que la macro doit résider dans le même classeur que le bouton et que le classeur doit être enregistré au format macro-enabled (.xlsm) pour être exécutable. Une approche efficace consiste donc à placer OpenConfig dans un module standard du fichier consolidé en .xlsm et à configurer le bouton pour appeler cette macro ouvrant le fichier config.xlsx (chemin évaluable via le code ou une référence).
-
Sub Merge() Dim sourceWorkbookNAS As Workbook Dim sourceWorkbookAcronis As Workbook Dim sourceWorkbookBootCatalog As Workbook Dim sourceWorkbookPRTG As Workbook Dim destinationWorkbook As Workbook Dim sourceSheet As Worksheet Dim destinationSheet As Worksheet Dim sourceFilePathNAS As String Dim sourceFilePathAcronis As String Dim sourceFilePathBootCatalog As String Dim sourceFilePathPRTG As String Dim destinationFilePath As String Dim configFilePath As String Dim sourceIndex As Integer Dim destinationIndex As Integer Dim lastRow As Long Dim currentDate As Date Dim formatdate As String Dim ws As Worksheet ' Chemins des fichiers source et destination formatdate = Format(Date, "dd_MM_yyyy") sourceFilePathNAS = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_NAS.xlsx" sourceFilePathAcronis = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_Acronis.xlsx" sourceFilePathBootCatalog = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_BootCatalog.xlsx" sourceFilePathPRTG = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_PRTG.xlsx" destinationFilePath = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_consolidated_report.xlsx" configFilePath = Environ("USERPROFILE") & "\Documents\mail\config.xlsx" ' Fichier Config pour gérer les noms des appareils ' Ouvrir les fichiers source et destination Set sourceWorkbookNAS = Workbooks.Open(sourceFilePathNAS) Set sourceWorkbookAcronis = Workbooks.Open(sourceFilePathAcronis) Set sourceWorkbookBootCatalog = Workbooks.Open(sourceFilePathBootCatalog) Set sourceWorkbookPRTG = Workbooks.Open(sourceFilePathPRTG) Set destinationWorkbook = Workbooks.Open(destinationFilePath) ' Initialiser les indices pour les feuilles sourceIndex = 1 destinationIndex = destinationWorkbook.Sheets.Count ' Commencer à la dernière feuille du destinationWorkbook ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' Transférer les données NAS dynamiquement Do While sourceIndex <= sourceWorkbookNAS.Sheets.Count And destinationIndex >= 1 Set sourceSheet = sourceWorkbookNAS.Sheets(sourceIndex) Set destinationSheet = destinationWorkbook.Sheets(destinationIndex) ' Trouver la dernière ligne avec des données dans la feuille source lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row ' Renommer la feuille de destination RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date du NAS ' Transférer les données dynamiques If lastRow >= 3 Then With sourceSheet ' Fusionner A6 et B6, et les définir égal à A1 du fichier source (date) With destinationSheet.Range("A6:B6") .Merge ' Fusionner les cellules A6 et B6 .Value = sourceSheet.Range("A2").Value ' Prendre la valeur de A2 du fichier source .Font.Size = 18 ' Taille de police 18 .Font.Bold = True ' Mettre en gras .Font.Color = RGB(255, 255, 255) ' Couleur du texte en blanc .Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB) .HorizontalAlignment = xlCenter ' Centrer le texte horizontalement .VerticalAlignment = xlCenter ' Centrer le texte verticalement End With ' Mettre en place les en-têtes "Description" et "Statut" destinationSheet.Range("A7").Value = "Description" destinationSheet.Range("B7").Value = "Statut" ' Boucle dynamique pour transférer les données des NAS Dim i As Long For i = 3 To lastRow destinationSheet.Cells(5 + i, 1).Value = .Cells(i, 1).Value ' Colonne A (Nom NAS) destinationSheet.Cells(5 + i, 2).Value = .Cells(i, 2).Value ' Colonne B (Statut NAS) Next i End With ' Appliquer la couleur bleu clair aux cellules A8 jusqu'à la dernière ligne With destinationSheet.Range("A7:B" & (5 + lastRow)) .Interior.Color = RGB(173, 216, 230) ' Bleu clair End With ' Appliquer des bordures sur la plage A6:B(lastRow) With destinationSheet.Range("A6:B" & (5 + lastRow)).Borders .LineStyle = xlContinuous ' Style de ligne continu .Weight = xlThin ' Épaisseur de la bordure (fine) .ColorIndex = 0 ' Couleur noire par défaut End With ' Appliquer la mise en forme conditionnelle pour le statut des NAS si nécessaire ApplyConditionalFormattingNAS destinationSheet, lastRow End If ' Passer à la feuille suivante dans source et précédente dans destination sourceIndex = sourceIndex + 1 destinationIndex = destinationIndex - 1 Loop ' Réinitialiser les indices pour les feuilles Acronis sourceIndex = 1 destinationIndex = destinationWorkbook.Sheets.Count ' Recommencer à la dernière feuille du destinationWorkbook ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' Transférer les données Acronis Do While sourceIndex <= sourceWorkbookAcronis.Sheets.Count And destinationIndex >= 1 Set sourceSheet = sourceWorkbookAcronis.Sheets(sourceIndex) Set destinationSheet = destinationWorkbook.Sheets(destinationIndex) ' Trouver la dernière ligne avec des données dans la feuille source lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row ' Renommer la feuille de destination RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date d'Acronis ' Transférer les données dynamiques If lastRow >= 3 Then With sourceSheet ' Fusionner C6 et D6, et les définir égal à A2 et B2 du fichier source With destinationSheet.Range("C6:D6") .Merge ' Fusionner les cellules C6 et D6 .Value = sourceSheet.Range("A2").Value ' Prendre la valeur de A2 du fichier source .Font.Size = 18 ' Taille de police 18 .Font.Bold = True ' Mettre en gras .Font.Color = RGB(255, 255, 255) ' Couleur du texte en blanc .Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB) .HorizontalAlignment = xlCenter ' Centrer le texte horizontalement .VerticalAlignment = xlCenter ' Centrer le texte verticalement End With destinationSheet.Range("C7").Value = "Description" destinationSheet.Range("D7").Value = .Range("B2").Value Dim j As Long For j = 3 To lastRow destinationSheet.Cells(5 + j, 3).Value = .Cells(j, 1).Value ' C column destinationSheet.Cells(5 + j, 4).Value = .Cells(j, 2).Value ' D column Next j End With ' Appliquer la couleur bleu clair aux cellules C8 jusqu'à la dernière ligne With destinationSheet.Range("C7:D" & (5 + lastRow)) .Interior.Color = RGB(173, 216, 230) ' Bleu clair End With ' Appliquer des bordures sur la plage C7:D11 With destinationSheet.Range("C6:D" & (5 + lastRow)).Borders .LineStyle = xlContinuous ' Style de ligne continu .Weight = xlThin ' Épaisseur de la bordure (fine) .ColorIndex = 0 ' Couleur noire par défaut End With ' Appliquer la couleur verte ou rouge selon la valeur des cellules D12 et D13 ApplyConditionalFormattingAcronis destinationSheet, lastRow End If ' Passer à la feuille suivante dans source et précédente dans destination sourceIndex = sourceIndex + 1 destinationIndex = destinationIndex - 1 Loop ' Réinitialiser les indices pour les feuilles PRTG sourceIndex = 1 destinationIndex = destinationWorkbook.Sheets.Count ' Recommencer à la dernière feuille du destinationWorkbook ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- 'Appliquer la couleur #18323F de E6:E10 For Each ws In destinationWorkbook.Sheets ws.Range("E6:E10").Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB) Next ws ' Transférer les données PRTG Do While sourceIndex <= sourceWorkbookPRTG.Sheets.Count And destinationIndex >= 1 Set sourceSheet = sourceWorkbookPRTG.Sheets(sourceIndex) Set destinationSheet = destinationWorkbook.Sheets(destinationIndex) ' Trouver la dernière ligne avec des données dans la feuille source lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row ' Renommer la feuille de destination RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date de PRTG With sourceSheet ' Fusionner F6 et G6 With destinationSheet.Range("F6:G6") .Merge ' Fusionner les cellules F6 et G6 .Value = "PRTG" .Font.Size = 18 ' Taille de police 18 .Font.Bold = True ' Mettre en gras .Font.Color = RGB(255, 255, 255) ' Couleur du texte en blanc .Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB) .HorizontalAlignment = xlCenter ' Centrer le texte horizontalement .VerticalAlignment = xlCenter ' Centrer le texte verticalement End With destinationSheet.Range("F7").Value = "Description" destinationSheet.Range("G7").Value = .Range("B2").Value Dim k As Long For k = 3 To lastRow destinationSheet.Cells(5 + k, 6).Value = .Cells(k, 1).Value ' F column destinationSheet.Cells(5 + k, 7).Value = .Cells(k, 2).Value ' G column Next k ' Appliquer la couleur bleu clair aux cellules F7 jusqu'à la dernière ligne With destinationSheet.Range("F7:G" & (5 + lastRow)) .Interior.Color = RGB(173, 216, 230) ' Bleu clair End With ' Appliquer des bordures sur la plage F7 jusqu'à la dernière ligne With destinationSheet.Range("F6:G" & (5 + lastRow)).Borders .LineStyle = xlContinuous ' Style de ligne continu .Weight = xlThin ' Épaisseur de la bordure (fine) .ColorIndex = 0 ' Couleur noire par défaut End With ' Appliquer la couleur verte ou rouge selon la valeur des cellules G13 et au-delà ApplyConditionalFormattingPRTG destinationSheet, lastRow End With ' Passer à la feuille suivante dans source et précédente dans destination sourceIndex = sourceIndex + 1 destinationIndex = destinationIndex - 1 Loop ' Réinitialiser les indices pour les feuilles Boot Catalog sourceIndex = 1 destinationIndex = destinationWorkbook.Sheets.Count ' Recommencer à la dernière feuille du destinationWorkbook ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' Transférer les données Boot Catalog Do While sourceIndex <= sourceWorkbookBootCatalog.Sheets.Count And destinationIndex >= 1 Set sourceSheet = sourceWorkbookBootCatalog.Sheets(sourceIndex) Set destinationSheet = destinationWorkbook.Sheets(destinationIndex) ' Trouver la dernière ligne avec des données dans la feuille source lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).row ' Renommer la feuille de destination RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date de Boot Catalog ' Transférer les données dynamiques If lastRow >= 3 Then With sourceSheet destinationSheet.Range("U11").Value = .Range("A1").Value destinationSheet.Range("U12").Value = .Range("A2").Value destinationSheet.Range("V12").Value = .Range("B2").Value Dim l As Long For l = 3 To lastRow destinationSheet.Cells(10 + l, 21).Value = .Cells(l, 1).Value ' T column destinationSheet.Cells(10 + l, 22).Value = .Cells(l, 2).Value ' U column Next l End With ' Appliquer la couleur bleu clair aux cellules T12 et U12 With destinationSheet.Range("U12:U" & (10 + lastRow)) .Interior.Color = RGB(173, 216, 230) ' Bleu clair End With End If ' Passer à la feuille suivante dans source et précédente dans destination sourceIndex = sourceIndex + 1 destinationIndex = destinationIndex - 1 Loop ' Mettre en forme le fichier destination et ajouter un bouton à chaque feuille For Each ws In destinationWorkbook.Sheets ' Centrage du contenu de la feuille ws.Cells.HorizontalAlignment = xlCenter ws.Cells.VerticalAlignment = xlCenter ws.Columns.AutoFit Next ws ' Enregistrer et fermer les classeurs destinationWorkbook.Close SaveChanges:=True sourceWorkbookNAS.Close SaveChanges:=False sourceWorkbookAcronis.Close SaveChanges:=False sourceWorkbookBootCatalog.Close SaveChanges:=False sourceWorkbookPRTG.Close SaveChanges:=False 'wbConfig.Close SaveChanges:=True 'Supprimer les fichiers sources Kill sourceFilePathNAS Kill sourceFilePathAcronis Kill sourceFilePathBootCatalog Kill sourceFilePathPRTG ' Libérer la mémoire Set sourceSheet = Nothing Set sourceWorkbookNAS = Nothing Set sourceWorkbookAcronis = Nothing Set sourceWorkbookBootCatalog = Nothing Set destinationSheet = Nothing Set destinationWorkbook = Nothing Set wbConfig = Nothing End SubVoici le code un peu plus organisé, je ne sais pas pourquoi la mise en page à sauté.
-
Bonjour,
Mets cette macro dans un module standard et rattache-la au bouton :
Sub OuvrirConfig() Workbooks.Open Environ("USERPROFILE") & "\Documents\mail\config.xlsx" End SubDaniel
-
Merci, mais je n'arrive tous de mêmes pas à créer le bouton via le code VBA est ensuite le relier à la macro afin de l'exécuter. J'ai rajouter ce code pour créer le bouton pour chaque feuille de mon classeur :
For Each ws In destinationWorkbook.Sheets ws.Buttons.Add(400, 10, 100, 30).OnAction = "OuvrirConfig" ws.Buttons(1).Characters.Text = "Ouvrir Config" Next wsMais lorsque je clique sur le bouton dans mon fichier excel, il me dit : "impossible d'exécuter la macro 'OuvrirConfig'. Il est possible qu'elle ne soit pas disponible dans ce classeur"
-
-
Ca devrait fonctionner. Tu n'as pas laissé aussi la macro dans un module feuille ? Si tu ne trouves pas, partage ton classeur.
Daniel
-
Bonjour,
Regarde le classeur :
https://www.cjoint.com/c/NJwhuXZCgT3
J'ai enregistré le classeur au format .xlsm (supportant les macros) et j'ai ajouté un module standard dans le quel j'ai mis OuvrirConfig.
Daniel
-
Je ne savais pas qu'il fallait que le fichier soit en .xlsm pour utilisé les macros, merci.
Toutefois, j'ai toujours le problème :
Dans ma fonction qui crée le fichier "consolidated_report", j'ai fais en sorte qu'il se créer en .xlsm (sans soucis, lorsque je regarde les propriété de mon fichier il est dans le bon format). Mais la fonction qui crée le bouton et qui est censé lui affecter la macro :
' Créer un bouton pour ouvrir le fichier de config sur chaque feuille avec la fonction OuvrirConfig() en tant que macro For Each ws In destinationWorkbook.Sheets ws.Buttons.Add(400, 10, 100, 30).OnAction = "OuvrirConfig" ws.Buttons(1).Characters.Text = "Ouvrir Config" Next wsDans mon fichier de report lorsque je clique sur le bouton, il me dit toujours "Impossible d'exécuter la macro "OuvrirConfig". Il est possible qu'elle ne soit pas disponible dans ce classeur ou que toutes les macros soient désactivées". Je ne sais pas si ça a avoir avec le fais que c'est à partir de outlook que j'essaie de lui affecter la macro même si je ne comprendrai pas pourquoi.
Et ducoup, j'ai changer le format aussi dans la macro :
-
-
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question -
Je ne suis pas sûr de comprendre. Ce n'est pas le fichier config qui doit être au format .xlsm, c'est celui qui comprend les macros (à moins que ce soit le même ???). Dans tous les cas, partage les classeurs qui posent problème.
-
"mais n'as pas la macro que je lui affecte " POURQUOI ???
https://www.cjoint.com/c/NJwjKusfRu3
Est-ce que le classeur à bien été créé par toi ? S'il provient d'internet, tu dois avoir ce bandeau rouge à l'ouverture du classeur (en français) :
il faut le débloquer dans les propriétés du fichier :
Daniel
-
Oui je sais, mais non je n'ai pas ça car c'est bien moi qui l'ai crée
-
Est-ce que tu as toujours le même problème que je t'ai retourné et qui fonctionne ici ?
Daniel
-
Je suis pas sur d'avoir compris, si vous me demandez est ce que quand je télécharge le lien que vous m'avez renvoyé ça fonctionne, la réponse est oui sinon je n'ai pas compris la question
-
Désolé, je pense plus vite que j'écris. C'est en effet incompréhensible. Je voulais donc dire :
Est-ce que tu as toujours le même problème avec le classeur que je t'ai retourné et qui fonctionne ici ?
Ca fonctionne donc chez toi. Le problème est donc résolu ?
Daniel
-
Non, le problème n'est pas réglé. Le classeur que vous m'avez retourné, fonctionne effectivement, seulement je pense qu'on c'est pas exactement compris sur ce que je veux.
Pour faire simple, j'ai un code de plus de 1200 lignes sur outlook qui fait en sorte de lire différents rapports de mail. Il crée ensuite, à partir de ces mails, 4 excels (car j'ai quatre dossier différents contenant des rapports), je les "rassemble" en 1 seul fichier excel (nommé "dateDuJour_consolidated_report"). Et dans ce rapport 'final', je voudrais qu'il y est un bouton qui permettre d'ouvrir le fichier de config utilisé pour les différents excels de rapport.
En gros j'ai ça dans outlook :
Ensuite j'ai crée une icone qui lancer le 'module11' :
Et à la fin, j'obtiens mon classeur finale nommé "dateDuJour_consolidated_report" avec le bouton mais il ne contient pas la macro : https://www.cjoint.com/c/NJwnypDlBxY
-
-
D'accord. A quoi sert la macro "Merge" qui semble être du code Excel ?
Daniel
-
Je pense avoir compris. Tu veux que la macro Merge ajoute la macro dans le classeur final ?
-
Deux choses à régler au préalable :
1. Ouvre le classeur contenant la macro Merge. Clique sur Fichier, Options, Centre de gestion de la confidentialité, Paramètres du Centre de gestion de la confidentialité. Dans Paramètres des macros, coche la case "Accès approuvé au modèle d'objet du projet VBA. Valide. Enregistre le classeur.
2. Dans l'éditeur VBA, clique sur Outils, Références. Coche la case "Microsoft Visual Basic For Applications Extensibility 5.3". Valide. Enregistre le classeur.
J'ai ajouté ce code :
'*** ajout du module "Module9" dans le fichier destination '*** la référence "Microsoft Visual Basic For Applications Extensibility 5.3" doit être cochée Dim proj As VBIDE.VBProject Dim comp As VBIDE.VBComponent Set proj = destinationWorkbook.VBProject Set comp = proj.VBComponents.Add(vbext_ct_StdModule) comp.Name = "Module9" Set codeMod = comp.CodeModule With codeMod lineNum = .CountOfLines + 1 .InsertLines lineNum, "Sub OuvrirConfig()" lineNum = lineNum + 1 .InsertLines lineNum, " Workbooks.Open Environ(""USERPROFILE"") & ""\Documents\mail\config.xlsx""" lineNum = lineNum + 1 .InsertLines lineNum, "End Sub" End Withavant la ligne :
' Enregistrer et fermer les classeurs
Soit le code complet (il manque l'ajout des boutons) :
Sub Merge() Dim sourceWorkbookNAS As Workbook Dim sourceWorkbookAcronis As Workbook Dim sourceWorkbookBootCatalog As Workbook Dim sourceWorkbookPRTG As Workbook Dim destinationWorkbook As Workbook Dim sourceSheet As Worksheet Dim destinationSheet As Worksheet Dim sourceFilePathNAS As String Dim sourceFilePathAcronis As String Dim sourceFilePathBootCatalog As String Dim sourceFilePathPRTG As String Dim destinationFilePath As String Dim configFilePath As String Dim sourceIndex As Integer Dim destinationIndex As Integer Dim lastRow As Long Dim currentDate As Date Dim formatdate As String Dim ws As Worksheet ' Chemins des fichiers source et destination formatdate = Format(Date, "dd_MM_yyyy") sourceFilePathNAS = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_NAS.xlsx" sourceFilePathAcronis = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_Acronis.xlsx" sourceFilePathBootCatalog = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_BootCatalog.xlsx" sourceFilePathPRTG = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_checkup_PRTG.xlsx" destinationFilePath = Environ("USERPROFILE") & "\Documents\mail\" & formatdate & "_consolidated_report.xlsx" configFilePath = Environ("USERPROFILE") & "\Documents\mail\config.xlsx" ' Fichier Config pour gérer les noms des appareils ' Ouvrir les fichiers source et destination Set sourceWorkbookNAS = Workbooks.Open(sourceFilePathNAS) Set sourceWorkbookAcronis = Workbooks.Open(sourceFilePathAcronis) Set sourceWorkbookBootCatalog = Workbooks.Open(sourceFilePathBootCatalog) Set sourceWorkbookPRTG = Workbooks.Open(sourceFilePathPRTG) Set destinationWorkbook = Workbooks.Open(destinationFilePath) ' Initialiser les indices pour les feuilles sourceIndex = 1 destinationIndex = destinationWorkbook.Sheets.Count ' Commencer à la dernière feuille du destinationWorkbook ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' Transférer les données NAS dynamiquement Do While sourceIndex <= sourceWorkbookNAS.Sheets.Count And destinationIndex >= 1 Set sourceSheet = sourceWorkbookNAS.Sheets(sourceIndex) Set destinationSheet = destinationWorkbook.Sheets(destinationIndex) ' Trouver la dernière ligne avec des données dans la feuille source lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row ' Renommer la feuille de destination RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date du NAS ' Transférer les données dynamiques If lastRow >= 3 Then With sourceSheet ' Fusionner A6 et B6, et les définir égal à A1 du fichier source (date) With destinationSheet.Range("A6:B6") .Merge ' Fusionner les cellules A6 et B6 .Value = sourceSheet.Range("A2").Value ' Prendre la valeur de A2 du fichier source .Font.Size = 18 ' Taille de police 18 .Font.Bold = True ' Mettre en gras .Font.Color = RGB(255, 255, 255) ' Couleur du texte en blanc .Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB) .HorizontalAlignment = xlCenter ' Centrer le texte horizontalement .VerticalAlignment = xlCenter ' Centrer le texte verticalement End With ' Mettre en place les en-têtes "Description" et "Statut" destinationSheet.Range("A7").Value = "Description" destinationSheet.Range("B7").Value = "Statut" ' Boucle dynamique pour transférer les données des NAS Dim i As Long For i = 3 To lastRow destinationSheet.Cells(5 + i, 1).Value = .Cells(i, 1).Value ' Colonne A (Nom NAS) destinationSheet.Cells(5 + i, 2).Value = .Cells(i, 2).Value ' Colonne B (Statut NAS) Next i End With ' Appliquer la couleur bleu clair aux cellules A8 jusqu'à la dernière ligne With destinationSheet.Range("A7:B" & (5 + lastRow)) .Interior.Color = RGB(173, 216, 230) ' Bleu clair End With ' Appliquer des bordures sur la plage A6:B(lastRow) With destinationSheet.Range("A6:B" & (5 + lastRow)).Borders .LineStyle = xlContinuous ' Style de ligne continu .Weight = xlThin ' Épaisseur de la bordure (fine) .ColorIndex = 0 ' Couleur noire par défaut End With ' Appliquer la mise en forme conditionnelle pour le statut des NAS si nécessaire ApplyConditionalFormattingNAS destinationSheet, lastRow End If ' Passer à la feuille suivante dans source et précédente dans destination sourceIndex = sourceIndex + 1 destinationIndex = destinationIndex - 1 Loop ' Réinitialiser les indices pour les feuilles Acronis sourceIndex = 1 destinationIndex = destinationWorkbook.Sheets.Count ' Recommencer à la dernière feuille du destinationWorkbook ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' Transférer les données Acronis Do While sourceIndex <= sourceWorkbookAcronis.Sheets.Count And destinationIndex >= 1 Set sourceSheet = sourceWorkbookAcronis.Sheets(sourceIndex) Set destinationSheet = destinationWorkbook.Sheets(destinationIndex) ' Trouver la dernière ligne avec des données dans la feuille source lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row ' Renommer la feuille de destination RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date d'Acronis ' Transférer les données dynamiques If lastRow >= 3 Then With sourceSheet ' Fusionner C6 et D6, et les définir égal à A2 et B2 du fichier source With destinationSheet.Range("C6:D6") .Merge ' Fusionner les cellules C6 et D6 .Value = sourceSheet.Range("A2").Value ' Prendre la valeur de A2 du fichier source .Font.Size = 18 ' Taille de police 18 .Font.Bold = True ' Mettre en gras .Font.Color = RGB(255, 255, 255) ' Couleur du texte en blanc .Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB) .HorizontalAlignment = xlCenter ' Centrer le texte horizontalement .VerticalAlignment = xlCenter ' Centrer le texte verticalement End With destinationSheet.Range("C7").Value = "Description" destinationSheet.Range("D7").Value = .Range("B2").Value Dim j As Long For j = 3 To lastRow destinationSheet.Cells(5 + j, 3).Value = .Cells(j, 1).Value ' C column destinationSheet.Cells(5 + j, 4).Value = .Cells(j, 2).Value ' D column Next j End With ' Appliquer la couleur bleu clair aux cellules C8 jusqu'à la dernière ligne With destinationSheet.Range("C7:D" & (5 + lastRow)) .Interior.Color = RGB(173, 216, 230) ' Bleu clair End With ' Appliquer des bordures sur la plage C7:D11 With destinationSheet.Range("C6:D" & (5 + lastRow)).Borders .LineStyle = xlContinuous ' Style de ligne continu .Weight = xlThin ' Épaisseur de la bordure (fine) .ColorIndex = 0 ' Couleur noire par défaut End With ' Appliquer la couleur verte ou rouge selon la valeur des cellules D12 et D13 ApplyConditionalFormattingAcronis destinationSheet, lastRow End If ' Passer à la feuille suivante dans source et précédente dans destination sourceIndex = sourceIndex + 1 destinationIndex = destinationIndex - 1 Loop ' Réinitialiser les indices pour les feuilles PRTG sourceIndex = 1 destinationIndex = destinationWorkbook.Sheets.Count ' Recommencer à la dernière feuille du destinationWorkbook ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- 'Appliquer la couleur #18323F de E6:E10 For Each ws In destinationWorkbook.Sheets ws.Range("E6:E10").Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB) Next ws ' Transférer les données PRTG Do While sourceIndex <= sourceWorkbookPRTG.Sheets.Count And destinationIndex >= 1 Set sourceSheet = sourceWorkbookPRTG.Sheets(sourceIndex) Set destinationSheet = destinationWorkbook.Sheets(destinationIndex) ' Trouver la dernière ligne avec des données dans la feuille source lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row ' Renommer la feuille de destination RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date de PRTG With sourceSheet ' Fusionner F6 et G6 With destinationSheet.Range("F6:G6") .Merge ' Fusionner les cellules F6 et G6 .Value = "PRTG" .Font.Size = 18 ' Taille de police 18 .Font.Bold = True ' Mettre en gras .Font.Color = RGB(255, 255, 255) ' Couleur du texte en blanc .Interior.Color = RGB(24, 50, 63) ' Fond égal à #18323F (converti en RGB) .HorizontalAlignment = xlCenter ' Centrer le texte horizontalement .VerticalAlignment = xlCenter ' Centrer le texte verticalement End With destinationSheet.Range("F7").Value = "Description" destinationSheet.Range("G7").Value = .Range("B2").Value Dim k As Long For k = 3 To lastRow destinationSheet.Cells(5 + k, 6).Value = .Cells(k, 1).Value ' F column destinationSheet.Cells(5 + k, 7).Value = .Cells(k, 2).Value ' G column Next k ' Appliquer la couleur bleu clair aux cellules F7 jusqu'à la dernière ligne With destinationSheet.Range("F7:G" & (5 + lastRow)) .Interior.Color = RGB(173, 216, 230) ' Bleu clair End With ' Appliquer des bordures sur la plage F7 jusqu'à la dernière ligne With destinationSheet.Range("F6:G" & (5 + lastRow)).Borders .LineStyle = xlContinuous ' Style de ligne continu .Weight = xlThin ' Épaisseur de la bordure (fine) .ColorIndex = 0 ' Couleur noire par défaut End With ' Appliquer la couleur verte ou rouge selon la valeur des cellules G13 et au-delà ApplyConditionalFormattingPRTG destinationSheet, lastRow End With ' Passer à la feuille suivante dans source et précédente dans destination sourceIndex = sourceIndex + 1 destinationIndex = destinationIndex - 1 Loop ' Réinitialiser les indices pour les feuilles Boot Catalog sourceIndex = 1 destinationIndex = destinationWorkbook.Sheets.Count ' Recommencer à la dernière feuille du destinationWorkbook ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ' Transférer les données Boot Catalog Do While sourceIndex <= sourceWorkbookBootCatalog.Sheets.Count And destinationIndex >= 1 Set sourceSheet = sourceWorkbookBootCatalog.Sheets(sourceIndex) Set destinationSheet = destinationWorkbook.Sheets(destinationIndex) ' Trouver la dernière ligne avec des données dans la feuille source lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row ' Renommer la feuille de destination RenameSheet destinationSheet, sourceSheet.Range("A1").Value ' Utilisation de A1 pour la date de Boot Catalog ' Transférer les données dynamiques If lastRow >= 3 Then With sourceSheet destinationSheet.Range("U11").Value = .Range("A1").Value destinationSheet.Range("U12").Value = .Range("A2").Value destinationSheet.Range("V12").Value = .Range("B2").Value Dim l As Long For l = 3 To lastRow destinationSheet.Cells(10 + l, 21).Value = .Cells(l, 1).Value ' T column destinationSheet.Cells(10 + l, 22).Value = .Cells(l, 2).Value ' U column Next l End With ' Appliquer la couleur bleu clair aux cellules T12 et U12 With destinationSheet.Range("U12:U" & (10 + lastRow)) .Interior.Color = RGB(173, 216, 230) ' Bleu clair End With End If ' Passer à la feuille suivante dans source et précédente dans destination sourceIndex = sourceIndex + 1 destinationIndex = destinationIndex - 1 Loop ' Mettre en forme le fichier destination et ajouter un bouton à chaque feuille For Each ws In destinationWorkbook.Sheets ' Centrage du contenu de la feuille ws.Cells.HorizontalAlignment = xlCenter ws.Cells.VerticalAlignment = xlCenter ws.Columns.AutoFit Next ws '*** ajout du module "Module9" dans le fichier destination '*** la référence "Microsoft Visual Basic For Applications Extensibility 5.3" doit être cochée Dim proj As VBIDE.VBProject Dim comp As VBIDE.VBComponent Set proj = destinationWorkbook.VBProject Set comp = proj.VBComponents.Add(vbext_ct_StdModule) comp.Name = "Module9" Set codeMod = comp.CodeModule With codeMod lineNum = .CountOfLines + 1 .InsertLines lineNum, "Sub OuvrirConfig()" lineNum = lineNum + 1 .InsertLines lineNum, " Workbooks.Open Environ(""USERPROFILE"") & ""\Documents\mail\config.xlsx""" lineNum = lineNum + 1 .InsertLines lineNum, "End Sub" End With ' Enregistrer et fermer les classeurs destinationWorkbook.Close SaveChanges:=True sourceWorkbookNAS.Close SaveChanges:=False sourceWorkbookAcronis.Close SaveChanges:=False sourceWorkbookBootCatalog.Close SaveChanges:=False sourceWorkbookPRTG.Close SaveChanges:=False 'wbConfig.Close SaveChanges:=True 'Supprimer les fichiers sources Kill sourceFilePathNAS Kill sourceFilePathAcronis Kill sourceFilePathBootCatalog Kill sourceFilePathPRTG ' Libérer la mémoire Set sourceSheet = Nothing Set sourceWorkbookNAS = Nothing Set sourceWorkbookAcronis = Nothing Set sourceWorkbookBootCatalog = Nothing Set destinationSheet = Nothing Set destinationWorkbook = Nothing Set wbConfig = Nothing End SubNote : Tu peux ôter la macro OuvrirConfig du code Outlook.
Daniel
-
On a encore un petit soucis, le soucis étant qu'enfaite je n'ai pas accès au classeur au préalable, enfaite Merge() est une fonction qui rassemble tous les excels en 1 seul puis après l'avoir fais, j'ai accès au classeur final. Seulement je voudrais que lorsque que j'y est accès, le bouton soit déjà paramétré avec la macro.
Je sais pas si c'est clair, mais en gros il faut retenir que je ne peux pas accéder au classeur, je gère absolument tout via le code. Ce que je voudrais c'est qu'a aucun moment je n'ai besoin d'ouvrir le classeur pour faire fonctionner la macro.Ce que je t'ai dit, c'est à faire une seule fois. Le point 1 doit être fait sur l'ordi qui exécute la macro Merge. C'est obligatoire.
Le point 2 doit être fait dans le classeur qui contient la macro Merge, une fois pour toutes. Je suppose que si tu peux modifier la macro, tu peu modifier les références ? A la limite, ce point peut être réglé via VBA.
Sinon, l'alternative serait de faire l'ajout à l'ouverture du classeur de destination. Reste que l'"Accès approuvé au modèle d'objet du projet VBA" devra être activé sur l'ordi qui ouvrira la classeur.
-
-
J'ajoute les boutons ou tu le fais ?
Daniel
-
J'ai ajouté les boutons et ça fonctionne parfaitement, je vous remercie !!
