Bonsoir à tous,
Tes 2 feuilles dans le même classeur.
Feuille"F 69", attention au contenu de la cellule "H2" dont la comparaison doit s'effectuer avec les cellules de la colonne C de la feuille "Listing complet"
Idem pour le contenu du champ "adresse" qui n'est pas identique
A tester :
Option Explicit
Sub test()
Dim a, i As Long, j As Long, k As Long, numBloc As String
Dim myAreas As Areas, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.Comparemode = 1
With Sheets("F 69")
numBloc = .Range("h2").Value
Set dico(numBloc) = CreateObject("Scripting.Dictionary")
Set myAreas = .Columns(2).SpecialCells(2).Areas
For k = 1 To myAreas.Count
a = myAreas(k).CurrentRegion
For j = 2 To UBound(a, 2)
Set dico(numBloc)(a(1, j)) = CreateObject("Scripting.Dictionary")
dico(numBloc)(a(1, j)).Comparemode = 1
For i = 2 To UBound(a, 1)
dico(numBloc)(a(1, j))(a(i, 1)) = a(i, j)
Next
Next
Next
End With
Application.ScreenUpdating = False
With Sheets("Listing complet")
With .Range("b4").CurrentRegion
With .Offset(1, 3).Resize(.Rows.Count - 1, .Columns.Count - 3)
.ClearContents
End With
For i = 2 To .Rows.Count
If dico.exists(.Cells(i, 2).Value) Then
If dico(.Cells(i, 2).Value).exists(.Cells(i, 3).Value) Then
.Cells(i, 4).Resize(, dico(.Cells(i, 2).Value).Item(.Cells(i, 3).Value).Count).Value = _
dico(.Cells(i, 2).Value).Item(.Cells(i, 3).Value).items
End If
End If
Next
End With
End With
Set myAreas = Nothing
Set dico = Nothing
Application.ScreenUpdating = True
End Sub
klin89