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
AddItem:
' If not in list, add the item to unique list
If Not FoundMatch And Not IsEmpty(Element) Then
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

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.

StackExchange Code Review Q#96365, answer score: 6