Mise à jour automatique de données.

Option Explicit
Option Compare Text 'ne tient pas compte de la casse

Private Sub Worksheet_Activate() 'se lance quand la feuille est activée
Dim tablo, plage As Range, cel As Range, d As Object, i&, txt$
With Sheets("Prestataires Juridique")
  tablo = .Range("C4:D" & .[C65536].End(xlUp).Row) 'matrice, plus rapide
End With
Application.ScreenUpdating = False
[F3:IV65536].Clear 'efface tout
On Error Resume Next 'si aucun texte en F1:IV1
Set plage = [F1:IV1].SpecialCells(xlCellTypeConstants, 2)
If Err Then Exit Sub
On Error GoTo 0
For Each cel In plage
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(tablo) 'liste sans doublons, en majuscules
    txt = tablo(i, 1)
    If Left(txt, 3) = Left(cel, 3) Then d(UCase(txt)) = UCase(txt)
  Next
  If d.Count Then
    With cel.Offset(2).Resize(d.Count)
      .Value = Application.Transpose(d.Keys)
      .Sort .Cells, xlAscending, Header:=xlNo 'tri
      .Borders.LineStyle = 1 'bordures
    End With
  End If
Next
Application.ScreenUpdating = True
End Sub

Option Explicit
Option Compare Text 'ne tient pas compte de la casse

Private Sub Worksheet_Activate() 'se lance quand la feuille est activée
Dim tablo, plage As Range, cel As Range, d As Object, i&, txt$
With Sheets("Prestataires Juridique")
  tablo = .Range("C4:D" & .[C65536].End(xlUp).Row) 'matrice, plus rapide
End With
Application.ScreenUpdating = False
[F3:IV65536].Clear 'efface tout
If Application.CountA([F1:IV1]) = 0 Then Exit Sub
Set plage = [F1:IV1].SpecialCells(xlCellTypeConstants)
For Each cel In plage
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(tablo) 'liste sans doublons, en majuscules
    txt = tablo(i, 1)
    If Left(txt, 3) = Left(cel, 3) Then d(UCase(txt)) = UCase(txt)
  Next
  If d.Count Then
    With cel.Offset(2).Resize(d.Count)
      .Value = Application.Transpose(d.Keys)
      .Sort .Cells, xlAscending, Header:=xlNo 'tri
      .Borders.LineStyle = 1 'bordures
    End With
  End If
Next
Application.ScreenUpdating = True
End Sub

Option Explicit
Option Compare Text 'ne tient pas compte de la casse

Private Sub Worksheet_Activate() 'se lance quand la feuille est activée
Dim tablo, plage As Range, cel As Range, txt1$, d As Object, i&, txt2$
With Sheets("Prestataires Juridique")
  tablo = .Range("C4:D" & .[C65536].End(xlUp).Row) 'matrice, plus rapide
End With
Application.ScreenUpdating = False
[F3:IV65536].Clear 'efface tout
If Application.CountA([F1:IV1]) = 0 Then Exit Sub
Set plage = [F1:IV1].SpecialCells(xlCellTypeConstants)
For Each cel In plage
  If cel <> "" Then 'pour cellule vide dans cellule fusionnée
    txt1 = Left(cel, 3)
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(tablo) 'liste sans doublons, en majuscules
      txt2 = tablo(i, 1)
      If Left(txt2, 3) = txt1 Then d(UCase(txt2)) = UCase(txt2)
    Next
    If d.Count Then
      With Cells(3, cel.Column).Resize(d.Count, 1)
        .Value = Application.Transpose(d.Keys)
        If d.Count > 1 Then .Sort .Cells, xlAscending, Header:=xlNo 'tri
        .Borders.LineStyle = 1 'bordures
      End With
    End If
  End If
Next
Application.ScreenUpdating = True
End Sub