copier un tableau via VBA (données et couleur de fond)

Sub ListeEnCouleur()
Dim P As Range, dest As Range, restitution As Byte, t, ncol%
Dim d As Object, dcoul As Object, i&, j%
Set P = [D5:M8] 'à adapter
Set dest = [B18] 'à adapter
restitution = 0 '0 en colonne, 1 en ligne
t = P 'matrice, plus rapide
ncol = UBound(t, 2)
Set d = CreateObject("Scripting.Dictionary")
Set dcoul = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Rows(dest.Row & ":" & Rows.Count).Clear 'RAZ
For i = 1 To UBound(t)
  For j = 1 To ncol
    If t(i, j) <> "" Then
      If Not d.exists(t(i, j)) Then dcoul(t(i, j)) = P(i, j).Interior.Color
      d(t(i, j)) = d(t(i, j)) + 1
    End If
  Next
Next
If d.Count = 0 Then Exit Sub
'---restitution des prénoms et des nombres avec tri alphabétique---
If restitution Then
  dest.Resize(, d.Count) = d.keys
  dest(2).Resize(, d.Count) = d.items
  dest.Resize(2, d.Count).Sort dest, xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
Else
  dest.Resize(d.Count) = Application.Transpose(d.keys)
  dest(, 2).Resize(d.Count) = Application.Transpose(d.items)
  dest.Resize(d.Count, 2).Sort dest, xlAscending, Header:=xlNo, Orientation:=xlTopToBottom
End If
'---restitution des couleurs---
For Each dest In IIf(restitution, dest.Resize(, d.Count), dest.Resize(d.Count))
  dest.Interior.Color = dcoul(dest.Value)
Next
End Sub