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 UCase(Trim(ActiveSheet.Range(Col & i).Value)) = UCase(Trim(tNoms(k))) Then Exit For
Next k
If k > UBound(tNoms) Then
ReDim Preserve tNoms(0 To UBound(tNoms) + 1)
tNoms(UBound(tNoms)) = ActiveSheet.Range(Col & i).Value
End If
Next i
Next Col
'Liste des communs en table tCommuns()
For Each Nom In tNoms
If Not IsEmpty(Nom) Then
For Each Col In tCols
k = ActiveSheet.Range(Col & Rows.Count).End(xlUp).Row
If k > NbLigTitre Then
For i = NbLigTitre + 1 To k
If UCase(Trim(ActiveSheet.Range(Col & i).Value)) = UCase(Trim(Nom)) Then Exit For
Next i
If i > k Then Exit For
End If
Next Col
If IsEmpty(Col) Then
ReDim Preserve tCommuns(0 To UBound(tCommuns) + 1)
tCommuns(UBound(tCommuns)) = Nom
'MsgBox Nom
End If
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
Comprends pas.juste une petite chose avec un bouton pour déclencher la macro
C'est plus compliqué: si oui
On laisse comme cela
Option Explicit
Private Const NbLigTitre = 1
Private Const ColonneNoms = "K,L,M,N,O"
Private Const ColonneResultat = "P"
Type Plage
tVal() As Variant
End Type
Sub NomsCommuns()
Dim WS As Worksheet
Dim tCols() As Plage
Dim tNoms() As Variant
Dim tColonneNoms() As String
Dim i As Integer, j As Integer, k As Integer, n As Integer, p As Integer
'Initialisations
Set WS = ActiveSheet
tColonneNoms = Split("," & ColonneNoms, ",") '"," devant LBound = 0 non utilisé
ReDim tCols(1 To UBound(tColonneNoms))
'Efface le résultat précédent
k = WS.Range(ColonneResultat & Rows.Count).End(xlUp).Row
If k > NbLigTitre Then WS.Range(ColonneResultat & NbLigTitre + 1 & ":" & ColonneResultat & k).ClearContents
'Toutes les colonnes en table tCols()
For i = 1 To UBound(tColonneNoms)
k = WS.Range(tColonneNoms(i) & Rows.Count).End(xlUp).Row - NbLigTitre
n = n + IIf(k > 0, k, 0)
ReDim tCols(i).tVal(0 To 0)
If k > 0 Then tCols(i).tVal = WS.Cells(1, tColonneNoms(i)).Offset(NbLigTitre, 0).Resize(k).Value
Next i
'Tous les noms en table tNoms()
If n = 0 Then Exit Sub
ReDim tNoms(1 To n, 1 To 1)
n = 0
For i = 1 To UBound(tCols)
For j = 1 To UBound(tCols(i).tVal, 1)
If Len(Trim(tCols(i).tVal(j, 1))) = 0 Then
MsgBox "Erreur: Nom vide en cellule " & tColonneNoms(i) & j + NbLigTitre & " !"
Exit Sub
End If
For k = 1 To n
If UCase(Trim(tCols(i).tVal(j, 1))) = UCase(Trim(tNoms(k, 1))) Then Exit For
Next k
If k > n Then
n = n + 1
tNoms(n, 1) = tCols(i).tVal(j, 1)
End If
Next j
Next i
'Tous les noms communs en haut de la table tNoms()
p = 0
For k = 1 To n
For i = 1 To UBound(tCols)
If UBound(tCols(i).tVal, 1) > 0 Then
For j = 1 To UBound(tCols(i).tVal, 1)
If UCase(Trim(tCols(i).tVal(j, 1))) = UCase(Trim(tNoms(k, 1))) Then Exit For
Next j
If j > UBound(tCols(i).tVal, 1) Then Exit For
End If
Next i
If i > UBound(tCols) Then
p = p + 1
tNoms(p, 1) = tNoms(k, 1)
'MsgBox Nom
End If
Next k
'Affectation du résultat
Application.ScreenUpdating = False
If p Then WS.Cells(1, ColonneResultat).Offset(NbLigTitre, 0).Resize(p).Value = tNoms
Application.ScreenUpdating = True
End Sub