Garnissage tableau en VBA

Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, c As Range, t$, n&, rest()
Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next 'si une plage est vide
For Each w In Worksheets
  If w.Name <> "COMPIL" Then
    'modifier éventuellement la plage étudiée
    For Each c In w.[B4:H100].SpecialCells(xlCellTypeConstants, 2)
      t = Application.Trim(c) 'SUPPRESPACE
      If Not d.exists(t) Then
        n = n + 1
        d(t) = n
        ReDim Preserve rest(1 To 8, 1 To n) 'tableau transposé
        rest(1, n) = t
      End If
      rest(c.Column, d(t)) = t
    Next
  End If
Next
'---restitution et tri alphabétique sur colonne A auxiliaire---
Application.ScreenUpdating = False
Range("A3:H" & Rows.Count).Clear 'RAZ
[A3].Resize(n, 8) = Application.Transpose(rest)
[A3].Resize(n, 8).Sort [A3], xlAscending, Header:=xlNo
[A3].Resize(n) = ""
'---bordures et largeur des colonnes---
With [B3].Resize(n, 7)
  .Borders(xlEdgeLeft).Weight = xlMedium
  .Borders(xlEdgeRight).Weight = xlMedium
  .Borders(xlInsideVertical).Weight = xlMedium
  .Borders(xlEdgeBottom).Weight = xlThin
  .Borders(xlInsideHorizontal).Weight = xlThin
  .EntireColumn.AutoFit
End With
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, c As Range, t$, n&, rest()
Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next 'si une plage est vide
For Each w In Worksheets
  If w.Name <> "COMPIL" Then
    'modifier éventuellement la plage étudiée
    For Each c In w.[B4:H100].SpecialCells(xlCellTypeConstants, 2)
      t = Application.Trim(c) 'SUPPRESPACE
      If Not d.exists(t) Then
        n = n + 1
        d(t) = n
        ReDim Preserve rest(1 To 8, 1 To n) 'tableau transposé
        rest(1, n) = t
      End If
      rest(c.Column, d(t)) = "ü" 'coche
    Next
  End If
Next
'---restitution et tri alphabétique sur colonne A auxiliaire---
Application.ScreenUpdating = False
Range("A3:H" & Rows.Count).Clear 'RAZ
[A3].Resize(n, 8) = Application.Transpose(rest)
[A3].Resize(n, 8).Sort [A3], xlAscending, Header:=xlNo
'---formatage---
With [A3].Resize(n, 8)
  .Borders(xlEdgeLeft).Weight = xlMedium
  .Borders(xlEdgeRight).Weight = xlMedium
  .Borders(xlInsideVertical).Weight = xlMedium
  .Borders(xlEdgeBottom).Weight = xlThin
  .Borders(xlInsideHorizontal).Weight = xlThin
End With
[A2].Resize(n + 1).Columns.AutoFit
[B3].Resize(n, 7).Font.Name = "Wingdings"
[B3].Resize(n, 7).HorizontalAlignment = xlCenter
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, c As Range, t$, n&, rest()
Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next 'si une plage est vide
For Each w In Worksheets
  If w.Name <> "COMPIL" Then
    'modifier éventuellement la plage étudiée
    For Each c In w.[B4:H100].SpecialCells(xlCellTypeConstants, 2)
      t = Application.Trim(c) 'SUPPRESPACE
      If Not d.exists(t) And t <> "" Then
        n = n + 1
        d(t) = n
        ReDim Preserve rest(1 To 8, 1 To n) 'tableau transposé
        rest(1, n) = t
      End If
      rest(c.Column, d(t)) = w.Name '= w.[A2]
    Next
  End If
Next
'---restitution, tri et formatage---
Application.ScreenUpdating = False
Range("A3:H" & Rows.Count).Delete xlUp 'RAZ
With [A3].Resize(n, 8)
  .Value = Application.Transpose(rest)
  .Sort [A3], xlAscending, Header:=xlNo
  '---bordures---
  .Borders(xlEdgeLeft).Weight = xlMedium
  .Borders(xlEdgeRight).Weight = xlMedium
  .Borders(xlInsideVertical).Weight = xlMedium
  .Borders(xlEdgeBottom).Weight = xlThin
  .Borders(xlInsideHorizontal).Weight = xlThin
End With
[A2].Resize(n + 1).Columns.AutoFit
End Sub