1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
| Sub test()
Dim Data As Object
Dim i As Integer
Dim k As Integer
Dim Tablo As Variant
Dim tabMatrice() As Variant
Dim DerLi As Long
Dim F4 As Worksheet
Dim F6 As Worksheet
Dim Ligne As Long, Colonne As Long
Dim C As Range
Set F4 = Worksheets("Feuil4")
Set F6 = Worksheets("Feuil6")
DerLi = F6.Columns("B").Find("*", , , , , xlPrevious).Row
'Tri feuil6
If Val(Application.Version) < 12 Then
F6.Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Else
F6.Sort.SortFields.Add Key:=Range("A1:A" & DerLi), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With F6.Sort
.SetRange Range("A1:B" & DerLi)
End With
End If
'Mise à zéro Feuil4
For Each C In F4.Range("A1").CurrentRegion
If C = 1 Then C = 0
Next C
'Création d'un dictionnaire pour trouver les doublons
Set Data = CreateObject("Scripting.Dictionary")
k = 0
Dim a As Variant
Tablo = F6.Range("B1:B" & DerLi).Value
For i = 1 To UBound(Tablo)
On Error Resume Next
Data.Add Tablo(i, 1), i 'i = ligne, ajuster au besoin
If Err.Number <> 0 Then 'si l'élément existe
k = k + 1
ReDim Preserve tabMatrice(3, k)
tabMatrice(1, k) = Tablo(i, 1) 'élément en double
tabMatrice(2, k) = F6.Cells(i, 1) 'posseseur 1
tabMatrice(3, k) = F6.Cells(Data(Tablo(i, 1)), 1) 'posseseur 2
End If
Next i
For i = 1 To UBound(tabMatrice)
Ligne = F4.Range("A1").CurrentRegion.Find(tabMatrice(2, i), , , , , xlPrevious).Row
Colonne = F4.Range("A1").CurrentRegion.Find(tabMatrice(3, i), , , , , xlPrevious).Column
F4.Cells(Ligne, Colonne) = 1
Next i
End Sub |
