Here is Another version, which will Return Value or Formula ,
Note: Using Rand(), RandBetween(),Now() etc ,can give different Result.
Code:
Sub ExcludeFromList()
Dim objDicMap As Object
Dim VarArrData
Dim VarArrResult
Dim rngCell As Range
Dim lngCOunt As Long
VarArrData = Intersect(Range("rngRange").CurrentRegion, Range("rngRange").CurrentRegion.Offset(1)).Formula
Set objDicMap = CreateObject("Scripting.Dictionary") ' Dictionary Object get Mapping
'Filling Dictionary
For Each rngCell In Intersect(Range("MapDelete").CurrentRegion, Range("MapDelete").CurrentRegion.Offset(1))
If Not objDicMap.exists(rngCell.Value) Then objDicMap.Add rngCell.Value, rngCell.Value
Next rngCell
'Filling Result Array From Data List which would not Include Mapping Data
For lngCOunt = LBound(VarArrData) To UBound(VarArrData)
If Not objDicMap.exists(Evaluate(VarArrData(lngCOunt, 1))) Then
If Not IsArray(VarArrResult) Then
ReDim VarArrResult(0 To 0)
VarArrResult(0) = VarArrData(lngCOunt, 1)
Else
ReDim Preserve VarArrResult(UBound(VarArrResult) + 1)
VarArrResult(UBound(VarArrResult)) = VarArrData(lngCOunt, 1)
End If
End If
Next lngCOunt
'Clear Old List
Range("rngRange").CurrentRegion.Offset(1).Clear
'Replace with new list
Range("rngRange").Offset(1).Resize(UBound(VarArrResult)).Value = Application.Transpose(VarArrResult)
Set objDicMap = Nothing
Set rngCell = Nothing
End Sub
Reply With Quote
Bookmarks