Sub VOC_ASST()
'Copies names from "Monthly Referals" sheet to "Voc_ Asst" Sheet.
'Prevents duplication of names.
Dim All As Range, R As Range
Dim Data
With Sheets("Referrals")
'Find all VR
Set All = FindAll(.Range("M:M"), "VR")
If All Is Nothing Then
MsgBox "No VR found."
Exit Sub
End If
'Map to column B
Set All = Intersect(All.EntireRow, .Range("B:B"))
'Get unique names
Data = UniqueItems(All, vbTextCompare)
End With
'Transpose to rows
Data = WorksheetFunction.Transpose(Data)
With Sheets("VOC_ASST")
'Find last column
Set R = .Cells(5, 1)
'Write the data
R.Resize(UBound(Data), 1).Value = Data
End With
End Sub
Private Function FindAll(ByVal Where As Range, ByVal What, _
Optional ByVal After As Variant, _
Optional ByVal LookIn As XlFindLookIn = xlValues, _
Optional ByVal LookAt As XlLookAt = xlWhole, _
Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
Optional ByVal MatchCase As Boolean = False, _
Optional ByVal SearchFormat As Boolean = False) As Range
'Find all occurrences of What in Where (Windows version)
Dim FirstAddress As String
Dim c As Range
'From FastUnion:
Dim Stack As New Collection
Dim Temp() As Range, Item
Dim i As Long, j As Long
If Where Is Nothing Then Exit Function
If SearchDirection = xlNext And IsMissing(After) Then
'Set After to the last cell in Where to return the first cell in Where in front if _
it match What
Set c = Where.Areas(Where.Areas.Count)
'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
'Set After = C.Cells(C.Cells.Count)
Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count))
End If
Set c = Where.find(What, After, LookIn, LookAt, SearchOrder, _
SearchDirection, MatchCase, SearchFormat:=SearchFormat)
If c Is Nothing Then Exit Function
FirstAddress = c.Address
Do
Stack.Add c
If SearchFormat Then
'If you call this function from an UDF and _
you find only the first cell use this instead
Set c = Where.find(What, c, LookIn, LookAt, SearchOrder, _
SearchDirection, MatchCase, SearchFormat:=SearchFormat)
Else
If SearchDirection = xlNext Then
Set c = Where.FindNext(c)
Else
Set c = Where.FindPrevious(c)
End If
End If
'Can happen if we have merged cells
If c Is Nothing Then Exit Do
Loop Until FirstAddress = c.Address
'Get all cells as fragments
ReDim Temp(0 To Stack.Count - 1)
i = 0
For Each Item In Stack
Set Temp(i) = Item
i = i + 1
Next
'Combine each fragment with the next one
j = 1
Do
For i = 0 To UBound(Temp) - j Step j * 2
Set Temp(i) = Union(Temp(i), Temp(i + j))
Next
j = j * 2
Loop Until j > UBound(Temp)
'At this point we have all cells in the first fragment
Set FindAll = Temp(0)
End Function
Private Function UniqueItems(ByVal R As Range, _
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare, _
Optional ByRef Count) As Variant
'Return an array with all unique values in R
' and the number of occurrences in Count
Dim Area As Range, Data
Dim i As Long, j As Long
Dim Dict As Object 'Scripting.Dictionary
Set R = Intersect(R.Parent.UsedRange, R)
If R Is Nothing Then
UniqueItems = Array()
Exit Function
End If
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = Compare
For Each Area In R.Areas
Data = Area
If IsArray(Data) Then
For i = 1 To UBound(Data)
For j = 1 To UBound(Data, 2)
If Not Dict.Exists(Data(i, j)) Then
Dict.Add Data(i, j), 1
Else
Dict(Data(i, j)) = Dict(Data(i, j)) + 1
End If
Next
Next
Else
If Not Dict.Exists(Data) Then
Dict.Add Data, 1
Else
Dict(Data) = Dict(Data) + 1
End If
End If
Next
UniqueItems = Dict.Keys
Count = Dict.Items
Dim Msg As String, Ans As Variant
Msg = "Hey!!! Copying complete!! Any Thing Else?"
Ans = MsgBox(Msg, vbYesNo)
Select Case Ans
Case vbYes
Sheets("Referrals").Select
Case vbNo
GoTo Quit:
End Select
Quit: ActiveWorkbook.Close
End Function
