# Adding all IDs associated with a Fax to one Row

I found a custom function called UniqueItems() to use and then developed my own RemoveDups() and FaxesToUse() code:

Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
'   Accepts an array or range as input
'   If Count = True or is missing, the function returns the number of unique elements
'   If Count = False, the function returns a variant array of unique elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
'   If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
'   Counter for number of unique elements
NumUnique = 0
'   Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
'       Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
Exit For '(exit loop)
End If
Next i
'       If not in list, add the item to unique list
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
'   Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function


Here is the sub you need to find your Unique IDs and copy them over to the sheet "Use Me":

Sub FaxesToUse()
Dim LastRow As Long, CurRow As Long, UniqueTotal As Long, SubTotal As Long

UniqueTotal = InputBox("How Many Unique OtherIDs is Max?")
If Not UniqueTotal > 0 Then
Exit Sub
End If

LastRow = Range("A" & Rows.Count).End(xlUp).Row
SubTotal = 0
For CurRow = 2 To LastRow
SubTotal = UniqueItems(Range("A2:A" & CurRow))
If SubTotal > UniqueTotal Then
SubTotal = UniqueItems(Range("A2:A" & CurRow - 1))
Range("A1:B" & CurRow - 1).Copy
Sheets("Use Me").Cells.Clear
Sheets("Use Me").Range("A1").PasteSpecial xlPasteValues
Sheets("Use Me").Activate
MsgBox "Use Me Sheet rows contain " & SubTotal & " Unique OtherIDs"
Exit Sub
End If
Cells(CurRow, 1).EntireRow.Interior.Color = RGB(255, 255, 0)
Next CurRow

End Sub


That will get you a page that looks like this:

Now we just need to remove all the duplicate Faxes using this macro:

Sub RemoveDups()

Dim CurRow As Long, LastRow As Long, LastCol As Long, DestLast As Long, DestRng As Range, ws As Worksheet

Set ws = Sheets("Use Me")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

For CurRow = LastRow To 3 Step -1
Set DestRng = ws.Range("B2:B" & CurRow - 1).Find(ws.Range("B" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If DestRng Is Nothing Then
'Do Nothing
Else
DestLast = ws.Cells(DestRng.Row, Columns.Count).End(xlToLeft).Column + 1
ws.Cells(DestRng.Row, DestLast).Value = ws.Cells(CurRow, 1).Value
ws.Cells(CurRow, 1).EntireRow.Delete xlShiftUp
End If
Next CurRow
ws.Columns("B:B").Cut
ws.Columns("A:A").Insert Shift:=xlToRight
Application.CutCopyMode = False

LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
LastCol = 0
For CurRow = 2 To LastRow
If ws.Cells(CurRow, Columns.Count).End(xlToLeft).Column > LastCol Then
LastCol = ws.Cells(CurRow, Columns.Count).End(xlToLeft).Column
End If
Next CurRow

MsgBox "Use Me Sheet Rows contain " & UniqueItems(ws.Range(Cells(2, 2), Cells(LastRow, LastCol))) & " Unique OtherIDs"

End Sub


It leaves you with this:

I'm interested in cleaning this up and making it more efficient for larger data sets.

You could just use a dictionary to identify unique values, then use the dictionary to identify the matches and print them to the new sheet. This also eliminates the need for user input of "How many unique items max".

Doing it this way won't require as much coding, or calling any functions. In fact, it does it in one fell swoop, which should speed it up when there's a large amount of data. You could use the dictionary to pull the items into an array and then print the array, but I'm not certain it would speed up significantly more on this solution.

The trick to the dictionary is that it can't have duplicate keys - so it's doing your entire uniqueitems() in a simple loop.

In faxestouse you're copying and pasting - instead just define the worksheets and set the values without any need to use .activate - this is much cleaner.

Sub CombineOtherID()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row

Dim strA As String

'Will use each fax number only once as a dictionary key
For i = 2 To lastrow
strA = Cells(i, 2)
dict(strA) = 1
Next

Dim countkey As Integer
countkey = 2
Dim countcol As Integer
Dim wsorigin As Worksheet
Set wsorigin = ActiveSheet
Dim wstarget As Worksheet
Set wstarget = Sheets("Use Me")

wstarget.Range("A1") = "Faxes"
wstarget.Range("B1") = "Other IDs"

'Use the keys to populate the target sheet
For Each Key In dict.keys
wstarget.Cells(countkey, 1) = Key
countkey = countkey + 1
countcol = 2
For j = 2 To lastrow
If wsorigin.Cells(j, 2) Like Key Then
wstarget.Cells(countkey - 1, countcol) = wsorigin.Cells(j, 1)
countcol = countcol + 1
End If
Next
Next
End Sub


### Otherwise

Now, if I were to go through your code there's a few things I'd note.

Your inputbox isn't handling any errors. I'd make sure it specifies the numeric type -

UniqueTotal = Application.InputBox("How Many Unique OtherIDs is Max?", Type:=1)


I'm a bit fuzzy how UniqueItems returns to subtotal. If it's a single integer, I guess it would work as a pretty inefficient loop, but as a variant - it should fail:

Next you call the UniqueItems() function which can return the number of uniques or an array of uniques. I'm not confident your matching algorithm is the most efficient - instead I'd use the dictionary object. It will give you the array or if you want the count you can use the .count method to get that.

If you return the count, then If SubTotal > UniqueTotal will execute no problem as subtotal is long. If the UniqueItems returns a variant (array), you will get type mismatch when you set SubTotal = UniqueItems - so I'm not sure what your goal here is - you pass an array to a long to check if your function returns a value greater than user input - is this to check to see if the list is already only uniques? There must be a better way to do that.

Then you're going to use .copy and .paste with .activate to fill in your sheet, but again you call UniqueItems as True so you'll get numunique - which doesn't have a type but would work as an integer. However, if you call it with False you'll get an array passed to a long which would return a type mismatch.

As far as the inefficient loop goes -

For CurRow = 2 To LastRow
SubTotal = UniqueItems(Range("A2:A" & CurRow))
If SubTotal > UniqueTotal Then
SubTotal = UniqueItems(Range("A2:A" & CurRow - 1))
Range("A1:B" & CurRow - 1).Copy
Sheets("Use Me").Cells.Clear
Sheets("Use Me").Range("A1").PasteSpecial xlPasteValues
Sheets("Use Me").Activate
MsgBox "Use Me Sheet rows contain " & SubTotal & " Unique OtherIDs"
Exit Sub
End If
Cells(CurRow, 1).EntireRow.Interior.Color = RGB(255, 255, 0)
Next CurRow


You will loop through everything until you count larger than the user input and then copy and paste the range - how does this work? Won't it just return the x number of rows, indiscriminately? You might have an incomplete data set at this point on your new sheet.

I don't quite understand the RemoveDups() sub. I think it looks for duplicates in column B because you haven't reversed the array and column B is still Fax Numbers. But after that, I'm not sure how you're getting anywhere close to your output.

A couple of general points first. Your variable names are good and the indentation is sensible, although in RemoveDups the code needs indenting once more. It looks like you've declared most of your variables, except for NumUnique in the UniqueItems function. This makes me suspect that you might not be using Option Explicit in all your modules.

When using the Cells or the Range methods you should always qualify them with the worksheet and the workbook, e.g. Workbooks("book_name.xlsm").Worksheets("sheet_name").Range("A1") so there is no room for doubt or for error to sneak in. You only seem to include the worksheet when referring to cells on the "Use Me" sheet.

If you want to build a unique list of something in VBA then you should always consider the Dictionary object. This is in the Microsoft Scripting Runtime library which also has the FileSystemObject and related items (drives, folders, files, etc). For early binding, from the VBA IDE select Tools -> References and then find "Microsoft Scripting Runtime" in the list and check the checkbox.

I think that you should be using a Dictionary object for the fax numbers with Collection objects for the Ids associated with each fax number. The dictionary makes it easy to test if you've already found a value and the collection gives you a group of values over which you can iterate. Using these objects your code can get simplified to:

Option Explicit

Sub CreateReport()

Dim faxNumsDict As Scripting.Dictionary
Dim otherIdsCol As Collection
Dim theFaxNum As String, theOtherId As String
Dim lastRow As Long, curRow As Long, keyCounter As Long, otherIdCounter As Long
Dim dictKey As Variant, otherId As Variant

lastRow = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
Set faxNumsDict = New Dictionary

For curRow = 2 To lastRow
theFaxNum = CStr(Worksheets(1).Cells(RowIndex:=curRow, ColumnIndex:=2).Value)
theOtherId = CStr(Worksheets(1).Cells(RowIndex:=curRow, ColumnIndex:=1).Value)
If Not faxNumsDict.Exists(theFaxNum) Then ' Does this fax already exist in dictionary?
' create a new entry in the dictionary with an empty collection
End If
' Now update the collection
Next curRow

' Now write the results to "Use Me" sheet
keyCounter = 0
' Loop through the fax numbers
For Each dictKey In faxNumsDict.Keys
keyCounter = keyCounter + 1
Worksheets("Use Me").Cells(RowIndex:=keyCounter + 1, ColumnIndex:=1).Value = dictKey
' Set a reference to the Collection object
Set otherIdsCol = faxNumsDict.Item(CStr(dictKey))
otherIdCounter = 0
' Loop through all the entries in the Collection
For Each otherId In otherIdsCol
otherIdCounter = otherIdCounter + 1
Worksheets("Use Me").Cells(RowIndex:=keyCounter + 1, ColumnIndex:=otherIdCounter + 1).Value = otherId
Next otherId
Next dictKey

End Sub


You'll notice that I'm a fan of using named parameters for the Cells method (and also Offset) because I find it makes it very clear which row/column you are using. In the Offset method it is very easy to change the wrong parameter.