Private Sub Worksheet_Activate()
Dim c, d As Range
Dim arraynummer, x As Long
Dim laatsteregel, laatsteregelII As Long
Dim Namenlijst As String
Dim Namen()
Dim rOldList As Range
Set MyRangeI = Worksheets("Unieken")
Set MyRangeII = Worksheets("Gegevens")
'tegen knipperen van het beeld
Application.ScreenUpdating = False
'Leeg eerste de oude unieken lijst
MyRangeI.Range("A2:B" & MyRangeI.Range("A65536").End(xlUp).Row + 1).Clear
'Waar willen we de unieken vandaan halen
Set rOldList = MyRangeII.Range("B1:B" & MyRangeII.Range("B65536").End(xlUp).Row)
'Gebruik AdvancedFilter om de unieken te contr0oleen en te kopieren naar het blad Unieken
rOldList.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=MyRangeI.Range("A2"), Unique:=True
laatsteregel = MyRangeI.Range("A65536").End(xlUp).Row
laatsteregelII = MyRangeII.Range("A65536").End(xlUp).Row
'geef de array een bereik zodat alle namen er eventueel in passen
ReDim Namen(laatsteregelII)
For Each c In MyRangeI.Range("A2:A" & laatsteregel)
arraynummer = 1
For Each d In MyRangeII.Range("B1:B" & laatsteregelII)
If d.Value = c.Value Then
'vul de array met de naam Namen
Namen(arraynummer) = d.Offset(, -1).Value
arraynummer = arraynummer + 1
End If
Next
'loop door array heen om de gegevens om te zetten naar een string
'zodat deze makkelijker weer te geven is
For x = 1 To arraynummer - 1
If Namen(x) <> "" Then
If x = 1 Then
Namenlijst = Namen(1)
Else
Namenlijst = Namenlijst & ", " & Namen(x)
End If
Else
Exit For
End If
Next
'Vul de gegevens in
c.Offset(, 1) = Namenlijst
'maak de Namenlijst leeg voor de volgende vergelijking
Namenlijst = ""
'Geef de array weer x aantal lege plaatsen (eigenlijk leeg je hem nu)
ReDim Namen(laatsteregelII)
Next
'tegen knipperen van het beeld
Application.ScreenUpdating = True
End Sub
, maar als je het voorbeeld begrijpt dan zal het voldoende info opleveren om dit ook aan te kunnen.
.
