XL 2019 lister le contenu de cellule fusionné

Sub Transpose()
Dim source As Range, dest As Range, n As Byte
Set source = [C2:G5] '4 lignes
Set dest = [K2:N6] '5 lignes
Application.ScreenUpdating = False
dest.Resize(25).Clear 'RAZ
For n = 0 To 4
    source.Rows(1 + 4 * n).Resize(4).Copy
    With dest.Rows(1 + 5 * n).Resize(5)
        .PasteSpecial xlPasteAll, Transpose:=True
        .Cells.HorizontalAlignment = xlCenter 'centrage
        Range(.Cells(1, -1), .Cells).Borders.Weight = xlThin
        Range(.Cells(1, -1), .Cells).BorderAround Weight:=xlMedium
    End With
Next
[A1].Select
End Sub

Sub Transpose()
Dim source As Range, dest As Range, n As Byte, c As Range
Set source = [C2:G5] '4 lignes
Set dest = [K2:N6] '5 lignes
Application.ScreenUpdating = False
dest.Resize(25).Clear 'RAZ
For n = 0 To 4
    source.Rows(1 + 4 * n).Resize(4).Copy
    With dest.Rows(1 + 5 * n).Resize(5)
        .PasteSpecial xlPasteAll, Transpose:=True
        For Each c In .Cells
            If c.MergeCells Then
                With c.MergeArea
                    .UnMerge 'défusionne
                    .Cells = .Cells(1)
                End With
            End If
        Next c
        .Cells.HorizontalAlignment = xlCenter 'centragz
        Range(.Cells(1, -1), .Cells).Borders.Weight = xlThin
        Range(.Cells(1, -1), .Cells).BorderAround Weight:=xlMedium
    End With
Next n
[A1].Select
End Sub

Sub Compter()
Dim d As Object, dd As Object, P As Range, ncol%, i&, x$, j%, c As Range, n%
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set dd = CreateObject("Scripting.Dictionary")
dd.CompareMode = vbTextCompare 'la casse est ignorée
Set P = [C2:G21]
ncol = P.Columns.Count
For i = 1 To P.Rows.Count
    x = P(i, 0)
    For j = 1 To ncol
        Set c = P(i, j).MergeArea(1)
        If c <> "" And P(i, j).Column = c.Column Then
            d(c.Value) = ""
            dd(x & c) = dd(x & c) + 1 'comptage
        End If
Next j, i
n = d.Count
'---restitution---
With [I2] '1ère cellule de destination
    If n Then
        .Resize(n) = Application.Transpose(d.keys)
        For i = 1 To n
            For j = 2 To 5
                .Cells(i, j) = dd(.Cells(0, j) & .Cells(i, 1))
        Next j, i
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 5).ClearContents 'RAZ en dessous
End With
End Sub