Create unique list from four lists

B

Bill_S

I need a macro that takes four lists of people on the spreadsheet and creates
a single list of unique names, sorted alphabetically. The four ranges of
lists of people are: D11:D19, L11:L19, D26:D34, L26:L34. I need to paste the
unique list of names starting in cell D39. Thanks.
 
S

Steve Yandl

Assuming you want to sort alphabetical based on the first letter in each of
the cells, this is one option. It's probably more efficient to let Excel do
the sort rather than create the ADOR.Recordset but this should do the trick.

Steve Yandl

_________________________________________________

Sub GrabUniqueNames()

Const adVarChar = 200
Const MaxCharacters = 255

Dim strName As String
Dim nameArray()

Set objDic = CreateObject("Scripting.Dictionary")

For N = 11 To 19
strName = CStr(Cells(N, 4).Value)
If Not objDic.Exists(strName) Then
objDic.Add strName, strName
End If
strName = CStr(Cells(N, 12).Value)
If Not objDic.Exists(strName) Then
objDic.Add strName, strName
End If
Next N

For N = 26 To 34
strName = CStr(Cells(N, 4).Value)
If Not objDic.Exists(strName) Then
objDic.Add strName, strName
End If
strName = CStr(Cells(N, 12).Value)
If Not objDic.Exists(strName) Then
objDic.Add strName, strName
End If
Next N

If objDic.Count > 0 Then
nameArray = objDic.Keys
End If

Set DataList = CreateObject("ADOR.Recordset")
DataList.Fields.Append "myNames", adVarChar, MaxCharacters
DataList.Open

For m = 0 To UBound(nameArray)
DataList.AddNew
DataList("myNames") = nameArray(m)
DataList.Update
Next m

DataList.Sort = "myNames"

R = 39
DataList.MoveFirst
Do Until DataList.EOF
Cells(R, 4).Value = DataList.Fields.Item("myNames")
R = R + 1
DataList.MoveNext
Loop

Set objDic = Nothing
Set DataList = Nothing
End Sub

_______________________________________________
 
Top