Bonjour Roblochon
Impossible d'ouvrir le fichier
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
Une colonne auxiliaire n'est pas forcément une mauvaise solution selon moi.C'est peut-être possible d'éviter 1 colonne "de travail"
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
Par contre je suis parti sur 5 colonnes, et je m’aperçois il y a des jours on on ne travaille pas on peut avoir des semaine ou il y aura 4 jours avec des noms voir défois 3
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