Sub DansBDFPasDansH()
Dim der&, dermax, t, d(1 To 4), i&, col&, k&, bad, x
With Sheets("liste")
der = .UsedRange.Row + .UsedRange.Rows.Count - 1
t = .Range("b2:h" & der)
For i = 1 To 4
Set d(i) = CreateObject("scripting.dictionary")
d(i).CompareMode = vbTextCompare
col = 1 + 2 * (i - 1)
For k = 1 To UBound(t)
If t(k, col) <> "" Then d(i)(t(k, col)) = ""
Next k
Next i
For Each bad In d(4)
If d(1).exists(bad) Then d(1).Remove bad
Next bad
For Each x In d(1)
If Not d(2).exists(x) Then d(1).Remove x
Next x
For Each x In d(1)
If Not d(3).exists(x) Then d(1).Remove x
Next x
.Range("j2:j" & der).ClearContents: i = 1
If d(1).Count > 0 Then
ReDim r(1 To d(1).Count + 1, 1 To 1)
r(1, 1) = .Range("j1"): i = 1
.Range("j2:j" & d(1).Count).NumberFormat = "@"
For Each x In d(1): i = i + 1: r(i, 1) = x: Next
.Range("j1").Resize(UBound(r), 1) = r
Range("j1").Resize(UBound(r), 1).Sort key1:=.Range("j1"), order1:=xlAscending, MatchCase:=False, Header:=xlYes
End If
End With
End Sub