Sujet Précédent Sujet Suivant

Bouton VBA outlook pour ouvrir fichier

Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024 - 21 oct. 2024 à 10:58
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 - 23 oct. 2024 à 09:57

 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
A voir également:

15 réponses

Réponse 1 / 15
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
21 oct. 2024 à 11:00 
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

Voici le code un peu plus organisé, je ne sais pas pourquoi la mise en page à sauté.
0
Réponse 2 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
21 oct. 2024 à 12:55

Bonjour,

Mets cette macro dans un module standard et rattache-la au bouton :

Sub OuvrirConfig()
  Workbooks.Open Environ("USERPROFILE") & "\Documents\mail\config.xlsx"
End Sub

Daniel
0
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
21 oct. 2024 à 16:42

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 ws

Mais 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"

0
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143 > Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
21 oct. 2024 à 16:51

Ca fonctionne ici. Il ne faut pas que "OuvrirConfig" soit défini comme "private". Il faut aussi qu'elle soit dans un module standard, pas dans un module feuille.

Daniel

0
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024 > danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024
21 oct. 2024 à 17:14

Je débute en VBA donc peut être que c'est tout bête et que je ne place juste pas bien les fichiers. Mais ma macro est 'Module1' et mon fichier avec le code est 'Module11', ci-joint l'image de l'architecture de mes fichiers 

0
Réponse 3 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
21 oct. 2024 à 17:48

Ca devrait fonctionner. Tu n'as pas laissé aussi la macro dans un module feuille ? Si tu ne trouves pas, partage ton classeur.

Daniel
0
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 09:07

Bonjour,

Je n'ai pas trouvé, voici mon classeur https://www.cjoint.com/c/NJwhgbcQL2Y

0
Réponse 4 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
Modifié le 22 oct. 2024 à 09:27

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
0
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 10:55

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 ws

Dans 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 : 

 

0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
Modifié le 22 oct. 2024 à 11:17

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.
0
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 11:22

Euh oui effectivement, le fichier de config n'as pas besoin d'être en .xlsm, je me suis complétement embrouiller... Par contre je vous fais parvenir mon classeur 'consolidated_report' qui lui est bien au format .xlsm mais n'as pas la macro que je lui affecte : https://www.cjoint.com/c/NJwjulA4Hyz

0
Réponse 6 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
Modifié le 22 oct. 2024 à 11:47

"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
0
Réponse 7 / 15
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 12:19

Oui je sais, mais non je n'ai pas ça car c'est bien moi qui l'ai crée
0
Réponse 8 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
22 oct. 2024 à 12:54

Est-ce que tu as toujours le même problème que je t'ai retourné et qui fonctionne ici ?

Daniel
0
Réponse 9 / 15
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 13:07

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
0
Réponse 10 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
22 oct. 2024 à 14:59

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
0
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 15:24

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

0
Réponse 11 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
22 oct. 2024 à 15:58

D'accord. A quoi sert la macro "Merge" qui semble être du code Excel ?

Daniel
0
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 16:02

Elle sert justement à rassembler les 4 autres fichiers excel en un seul, c'est elle qui fait en sorte de "remplir" 'dateDuJour_consolidated_report'. 

0
Réponse 12 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
22 oct. 2024 à 16:11

Je pense avoir compris. Tu veux que la macro Merge ajoute la macro dans le classeur final ?
0
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 16:13

Oui c'est ça, je veux qu'a la fin de Merge, il ajoute un bouton avec une macro associé permettant d'ouvrir le fichier de config

0
Réponse 13 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
22 oct. 2024 à 16:45

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 With

avant 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 Sub

Note : Tu peux ôter la macro OuvrirConfig du code Outlook.

Daniel
0
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 16:51

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. 

0
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143 > Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
22 oct. 2024 à 16:59

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.

0
Réponse 14 / 15
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
22 oct. 2024 à 16:46

J'ajoute les boutons ou tu le fais ?

Daniel
0
Réponse 15 / 15
Morpheuuss Messages postés 14 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 23 octobre 2024
23 oct. 2024 à 09:08

J'ai ajouté les boutons et ça fonctionne parfaitement, je vous remercie !! 
0
danielc0 Messages postés 1270 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 20 novembre 2024 143
23 oct. 2024 à 09:57

Il n'y a plus de problème, alors ?

0

Discussions similaires

"Aucune application permettant d'ouvrir cette URL"
sidojaice -
JIP -

24 réponses
comment donner les droits sur fichier partage
ch'ti du 57 -
fil1958 -

2 réponses