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
| Option Explicit
Sub Creer_Liste_SansDoublons()
Dim WsSource As Worksheet, WsCible As Worksheet
Dim PlageS As Range, PlageC As Range, Cel As Range, c As Range, d As Range
Dim Collec As Collection
Dim DerLig As Long, i As Long, Compteur As Long
Dim Nom As String, firstAddress As String
Dim DateOuv As Date
Set WsSource = Workbooks("Données source.xls").Worksheets("Données source")
Set WsCible = Workbooks("Tableau cible.xls").Worksheets("Tableau cible")
Set Collec = New Collection
On Error Resume Next
Set PlageS = WsSource.Range("C2:C" & WsSource.Range("C" & WsSource.Rows.Count).End(xlUp).Row)
For Each Cel In PlageS
Nom = Trim(Split(Cel, "-")(1))
If Nom <> "" Then Collec.Add Nom, CStr(Nom)
Next Cel
On Error GoTo 0
For i = 1 To Collec.Count
Compteur = 0
DateOuv = Date
Set c = PlageS.Find(Collec.Item(i), LookIn:=xlValues, Lookat:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If c.Offset(0, -1) < DateOuv Then DateOuv = c.Offset(0, -1)
Compteur = Compteur + 1
Set c = PlageS.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
Set PlageC = WsCible.Range("A2:A" & WsCible.Range("A" & WsCible.Rows.Count).End(xlUp).Row)
Set d = PlageC.Find(Collec.Item(i), LookIn:=xlValues, Lookat:=xlWhole)
If Not c Is Nothing Then
d.Offset(0, 1) = Compteur
d.Offset(0, 2) = DateOuv
End If
End If
Set PlageC = Nothing
Set d = Nothing
Set c = Nothing
Next i
Set PlageS = Nothing
Set Collec = Nothing
Set WsSource = Nothing
Set WsCible = Nothing
End Sub |
Partager