XL 2016 lister des noms présent dans cinq colonnes

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xcol, n&, dico1, dico2, t, t0, i&, DeuxPlus As Boolean, xkey

   If Intersect(Columns("k:o"), Target) Is Nothing Then Exit Sub
   For Each xcol In Columns("k:o")
      If Not DeuxPlus Then
         n = xcol.Cells(Rows.Count, 1).End(xlUp).Row
         Set dico1 = CreateObject("scripting.dictionary")
         t = xcol.Resize(n)
         For i = 2 To UBound(t): dico1(t(i, 1)) = "": Next
         DeuxPlus = True
      Else
         n = xcol.Cells(Rows.Count, 1).End(xlUp).Row
         Set dico2 = CreateObject("scripting.dictionary")
         t = xcol.Resize(n)
         For i = 2 To UBound(t): dico2(t(i, 1)) = "": Next
         For Each xkey In dico1.keys
            If Not dico2.exists(xkey) Then dico1.Remove xkey
         Next xkey
      End If
   Next xcol
   Columns("p").ClearContents
   Range("p1") = "RESULTAT"
   If dico1.Count > 0 Then Range("p2").Resize(dico1.Count) = Application.Transpose(dico1.keys)
End Sub

Option Explicit

Private Const NbLigTitre = 1
Private Const ColonneNoms = "K,L,M,N,O"
Private Const ColonneResultat = "P"

Sub NomsCommuns()
    Dim tNoms() As Variant
    Dim tCommuns() As Variant
    Dim tCols() As String
    Dim Col As Variant
    Dim Nom As Variant
    Dim i As Integer
    Dim k As Integer
 
    'Initialisations
    tCols = Split(ColonneNoms, ",")
    ReDim tNoms(0 To 0)
    ReDim tCommuns(0 To 0)
 
    'Efface le résultat précédent
    k = ActiveSheet.Range(ColonneResultat & Rows.Count).End(xlUp).Row
    If k > NbLigTitre Then ActiveSheet.Range(ColonneResultat & NbLigTitre + 1 & ":" & ColonneResultat & k).ClearContents
     
    'Tous les noms en table tNoms()
    For Each Col In tCols
        k = ActiveSheet.Range(Col & Rows.Count).End(xlUp).Row
        For i = NbLigTitre + 1 To k
            For k = 1 To UBound(tNoms)
                If Trim(ActiveSheet.Range(Col & i).Value) = tNoms(k) Then Exit For
            Next k
            If k > UBound(tNoms) Then
                ReDim Preserve tNoms(0 To UBound(tNoms) + 1)
                tNoms(UBound(tNoms)) = Trim(ActiveSheet.Range(Col & i).Value)
            End If
        Next i
    Next Col
 
    'Liste des communs
    For Each Nom In tNoms
        For Each Col In tCols
            k = ActiveSheet.Range(Col & Rows.Count).End(xlUp).Row
            For i = NbLigTitre + 1 To k
                If Trim(ActiveSheet.Range(Col & i).Value) = Nom Then Exit For
            Next i
            If i > k Then Exit For
        Next Col
     
        If IsEmpty(Col) Then
            ReDim Preserve tCommuns(0 To UBound(tCommuns) + 1)
            tCommuns(UBound(tCommuns)) = Nom
            'MsgBox Nom
        End If
    Next Nom
 
    'Affectation du résultat
    Application.ScreenUpdating = False
    For i = 1 To UBound(tCommuns)
        ActiveSheet.Range(ColonneResultat & NbLigTitre + i).Value = tCommuns(i)
    Next i
    Application.ScreenUpdating = True

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xcol, n&, dico1, dico2, t, t0, i&, DeuxPlus As Boolean, xkey
 
   If Intersect(Columns("k:o"), Target) Is Nothing Then Exit Sub
   For Each xcol In Columns("k:o")
      If Not DeuxPlus Then
         n = xcol.Cells(Rows.Count, 1).End(xlUp).Row
         If n > 1 Then
            Set dico1 = CreateObject("scripting.dictionary")
            t = xcol.Resize(n)
            For i = 2 To UBound(t): dico1(t(i, 1)) = "": Next
            DeuxPlus = True
         End If
      Else
         n = xcol.Cells(Rows.Count, 1).End(xlUp).Row
         If n > 1 Then
            Set dico2 = CreateObject("scripting.dictionary")
            t = xcol.Resize(n)
            For i = 2 To UBound(t): dico2(t(i, 1)) = "": Next
            For Each xkey In dico1.keys
               If Not dico2.exists(xkey) Then dico1.Remove xkey
            Next xkey
         End If
      End If
   Next xcol
   Columns("p").ClearContents
   Range("p1") = "RESULTAT"
   If dico1.Count > 0 Then Range("p2").Resize(dico1.Count) = Application.Transpose(dico1.keys)
End Sub