Sujet Précédent

Bouton VBA outlook pour ouvrir fichier

Morpheuuss Messages postés 4 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 21 octobre 2024 - 21 oct. 2024 à 10:58
danielc0 Messages postés 1205 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 21 octobre 2024 - 21 oct. 2024 à 17:48

 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:

3 réponses

Réponse 1 / 3
Morpheuuss Messages postés 4 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 21 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 / 3
danielc0 Messages postés 1205 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 21 octobre 2024 139
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 4 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 21 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 1205 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 21 octobre 2024 139 > Morpheuuss Messages postés 4 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 21 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 4 Date d'inscription lundi 21 octobre 2024 Statut Membre Dernière intervention 21 octobre 2024 > danielc0 Messages postés 1205 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 21 octobre 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 / 3
danielc0 Messages postés 1205 Date d'inscription mardi 5 juin 2018 Statut Membre Dernière intervention 21 octobre 2024 139
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

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