Lister les lettres identiques à deux mots

Option Explicit
Function LettresCommunes(ByVal mot1 As String, mot2 As String) As String
Dim d As Object, t As Variant, s As String, i As Integer
  Set d = CreateObject("Scripting.Dictionary")
  If Len(mot2) > Len(mot1) Then
    s = mot2: mot2 = mot1: mot1 = s
  End If
  For i = 1 To Len(mot1)
    If InStr(1, LCase(mot2), LCase(Mid(mot1, i, 1))) > 0 Then d(UCase(Mid(mot1, i, 1))) = i
  Next i
  If d.Count = 0 Then
    LettresCommunes = ""
  Else
    t = d.Keys: d.RemoveAll
    Call Tri(t, LBound(t), UBound(t))
    LettresCommunes = Join(t, "")
  End If
End Function
Private Sub Tri(table As Variant, premier As Integer, dernier As Integer)
Dim v As Variant, t As Variant, p As Integer, d  As Integer
  p = premier: d = dernier: v = table((p + d) \ 2)
  Do
    Do While table(p) < v: p = p + 1: Loop
    Do While v < table(d): d = d - 1: Loop
    If p <= d Then
      t = table(p): table(p) = table(d): table(d) = t
      p = p + 1: d = d - 1
    End If
  Loop While p <= d
  If p < dernier Then Call Tri(table, p, dernier)
  If premier < d Then Call Tri(table, premier, d)
End Sub

Function LettresAuxMemesEmplacements(ByVal mot1 As String, mot2 As String) As String
Dim s As String, i As Integer
  For i = 1 To IIf(Len(mot2) > Len(mot1), Len(mot1), Len(mot2))
    If LCase(Mid(mot1, i, 1)) = LCase(Mid(mot2, i, 1)) Then
      s = s & UCase(Mid(mot1, i, 1))
    End If
  Next i
  LettresAuxMemesEmplacements = s
End Function