Microsoft 365 Faire un onglet de Récap de tous les onglets

Sub Synthèse2()
Dim ws As Worksheet
Dim WsSynt As Worksheet

Set WsSynt = Sheets("Synthèse_Projets")

Application.DisplayAlerts = False
WsSynt.UsedRange.Offset(6).Delete
Application.DisplayAlerts = True
        
For Each ws In ActiveWorkbook.Sheets
    If ws.Name <> "Projet modèle" And ws.Name Like "Projet" & "*" Then
        finsynt = Application.WorksheetFunction.Max(WsSynt.Range("B" & WsSynt.Rows.Count).End(xlUp).Row + 1, 7)
        With ws
             .Range("I10").Copy Destination:=WsSynt.Range("A" & finsynt)
            fin = .Range("G" & .Rows.Count).End(xlUp).Row
            
            Set zonetocopy = .Range("G23:R" & fin)
            zonetocopy.Copy Destination:=WsSynt.Range("B" & finsynt)
'            WsSynt.Range("A" & finsynt).Resize(zonetocopy.Rows.Count - 1).Merge
        End With
    End If
Next ws
With WsSynt
    finsynt = Application.WorksheetFunction.Max(.Range("B" & .Rows.Count).End(xlUp).Row + 1, 7)
    .Range("A7:M" & finsynt).UnMerge
    .Range("F7:F" & finsynt).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    finsynt = Application.WorksheetFunction.Max(.Range("B" & .Rows.Count).End(xlUp).Row + 1, 7)

    'remerger la colonne A
    deb = 7
    fin = 7
    i = 7
    Do
        If .Range("A" & i + 1) <> "" Or i = finsynt - 1 Then
            .Range("A" & deb & ":A" & fin).Merge
            deb = i + 1
            fin = i
        Else
            fin = i + 1
            
        End If
        i = i + 1
    Loop Until i > finsynt
    
End With
End Sub

Sub Synthèse2()
Application.ScreenUpdating = False 'désactivation du refresh d'écran pour éviter l'effet sapin de noel de l'écran et accélerer le temps de traitement
Dim ws As Worksheet
Dim WsSynt As Worksheet

Set WsSynt = Sheets("Synthèse_Projets")

Application.DisplayAlerts = False 'on désactive les messages d'alerte
WsSynt.UsedRange.Offset(6).Delete 'on efface la feuille de synthèse hors entete
Application.DisplayAlerts = True 'on réactive les messages d'alerte
        
For Each ws In ActiveWorkbook.Sheets 'pour chaque feuille du classeur
    If ws.Name <> "Projet modèle" And ws.Name Like "Projet" & "*" Then 'si on est sur une feuille projet (HORS projet modèle)
        finsynt = Application.WorksheetFunction.Max(WsSynt.Range("B" & WsSynt.Rows.Count).End(xlUp).Row + 1, 7) 'on récupère le numéro de la première ligne NON vide (fonction max pour compenser le pb de cellule fusionnée)
        With ws 'avec la feuille
             .Range("I10").Copy Destination:=WsSynt.Range("A" & finsynt) 'on copie la cellule I10
            fin = .Range("G" & .Rows.Count).End(xlUp).Row 'derniière ligne de la feuille à copier
            .Range("G23:R" & fin).Copy Destination:=WsSynt.Range("B" & finsynt) 'on copie toutes les données de la feuille (lignes vides incluses)
        End With
    End If
Next ws

' à ce stade de la macro, toutes les feuilles projets ont été importées dans la feuille de synthèse
With WsSynt 'dans la feuille synthèse
    finsynt = Application.WorksheetFunction.Max(.Range("B" & .Rows.Count).End(xlUp).Row + 1, 7) 'première ligne vide de la feuille sur la colonne B
    .Range("A7:M" & finsynt).UnMerge 'on supprime toutes les cellules fusionnées
    'suppression des lignes vides==> il faut avoir UNE colonne qui contiennet OBLIGATOIREMENT une donnée lorsque la ligne est à garder et AUCUNE donnée lorsqu'il faut la supprimer
    .Range("G7:G" & finsynt).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'suppose que la date de fin est TOUJOURS remplie
    
    finsynt = Application.WorksheetFunction.Max(.Range("B" & .Rows.Count).End(xlUp).Row + 1, 7) 'première ligne vide sur la colonne B

    'remerger la colonne A
    deb = 7
    fin = 7
    i = 7
    Do
        If .Range("B" & i) = "." Then .Range("C" & i).Resize(1, 2).Merge
        .Range("L" & i).Resize(1, 2).Merge
        If .Range("A" & i + 1) <> "" Or i = finsynt - 1 Then
            .Range("A" & deb & ":A" & fin).Merge
            deb = i + 1
            fin = i
        Else
            fin = i + 1
            
        End If
        i = i + 1
    Loop Until i > finsynt
    
    'un peu de mise en fore
    Set zone = .Range("A7:M" & finsynt - 1)
    
    With zone
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
End With
Application.ScreenUpdating = True
End Sub