XL 2016 lister des noms présent dans cinq colonnes

[eduraiss]

Bonjour le forum

Voila j'ai 5 colonne qui représente les jours de la semaine

En dessous chaque jour une liste de noms

j'aimerais lister dans une colonne résultat les noms qui sont présent dans les cinq colonnes

Je joins un fichier
Merci à vous

 

[Dudu2]

mapomme est trop rapide

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

 

[eduraiss]

Re
ça marche
juste une petite chose avec un bouton pour déclencher la macro
C'est plus compliqué: si oui
On laisse comme cela
Merci

 

[eduraiss]

Ben c'est exactement cela avec le dernier code

Merci beaucoup mapomme,Dudu2
Cordialement

 

[Dudu2]

juste une petite chose avec un bouton pour déclencher la macro
C'est plus compliqué: si oui
On laisse comme cela

Comprends pas.
Tu veux un fichier avec un bouton pour déclencher la macro ?

Edit: j'ai fait une modif mineure pour que les comparaisons de noms se fassent toutes en UCase(Trim()) en cas de différences de saisie.

 

[eduraiss]

Re
oui mais c'est bon avec le code du post 16
j'ai mis le code dans la feuille
inserer un bouton
Affecter la macro
NomsCommuns

Et ça fonctionne nickel
Peut être qu'il ne fallait pas faire comme cela?
Merci

 

[Dudu2]

Si si, 'est bien ça. Prends bien la dernière version modifiée pour assurer les comparaisons de noms si saisis de manière différente (blancs aux marges, minuscules...)

 

[eduraiss]

Re

Super merci encore
Cordialement,

 

[Dudu2]

Bonjour,
Comme on a du temps, je voulais voir à quel point c'était plus rapide de d'abord charger les valeurs de 5 x 250 cellules en table avant travailler dessus plutôt que de travailler directement sur les cellules.
Résultat ici: 3 fois plus rapide. Cest finalement relativement peu mais c'est parce que les valeurs sont en lecture seule. Ça vaut le coup si ce genre d'opération doit être réalisé sur un Worksheet_Change() par exemple pour réduire le temps de réponse du curseur.
Le code ci-dessous est aussi un peu plus sécurisé (vérifie nom vide, tout vide)

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