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
| '====================================================
'/!\ Cocher la réference Miscrosoft Scripting Runtime
'====================================================
Sub Test()
Dim MonDico As New Scripting.Dictionary
Dim i As Long, j As Long, n As Long
Dim TbSce, TbDes, Tmp
Dim Res As String
Dim k As Byte
Application.ScreenUpdating = False
With Feuil1
TbSce = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
For i = 1 To UBound(TbSce, 1)
If TbSce(i, 1) <> "" Then
Tmp = Split(TbSce(i, 1))
For k = LBound(Tmp) To UBound(Tmp)
If Tmp(k) <> "" And Not MonDico.exists(Tmp(k)) Then MonDico.Add Tmp(k), 0
Next k
End If
Next i
TbDes = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
n = MonDico.Count
ReDim TbSce(1 To n, 1 To 2)
For i = 0 To n - 1
For j = 1 To UBound(TbDes, 1)
If InStr(UCase(TbDes(j, 1)), UCase(MonDico.Keys(i))) Then MonDico(MonDico.Keys(i)) = MonDico(MonDico.Keys(i)) & ", " & j + 1
Next j
Res = Mid(MonDico(MonDico.Keys(i)), 4)
'=====Ici on peut adapter par exemple
'TbSce(i + 1, 1) = MonDico.Keys(i)
' TbSce(i + 1, 2) = Res
'Ou
TbSce(i + 1, 1) = MonDico.Keys(i) & IIf(Res <> "", " (Lignes: " & Res & ")", " (Absent)")
Next i
Set MonDico = Nothing
.Range("M2").Resize(n, 2) = TbSce
End With
End Sub |
Partager