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 &gt; 0 Then
        Exit Sub
    End If

    LastRow = Range("A" &amp; Rows.Count).End(xlUp).Row
    SubTotal = 0
    For CurRow = 2 To LastRow
        SubTotal = UniqueItems(Range("A2:A" &amp; CurRow))
        If SubTotal &gt; UniqueTotal Then
            SubTotal = UniqueItems(Range("A2:A" &amp; CurRow - 1))
            Range("A1:B" &amp; 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 " &amp; SubTotal &amp; " 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" &amp; Rows.Count).End(xlUp).Row

For CurRow = LastRow To 3 Step -1
     Set DestRng = ws.Range("B2:B" &amp; CurRow - 1).Find(ws.Range("B" &amp; 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" &amp; Rows.Count).End(xlUp).Row
LastCol = 0
For CurRow = 2 To LastRow
    If ws.Cells(CurRow, Columns.Count).End(xlToLeft).Column &gt; LastCol Then
        LastCol = ws.Cells(CurRow, Columns.Count).End(xlToLeft).Column
    End If
Next CurRow

MsgBox "Use Me Sheet Rows contain " &amp; UniqueItems(ws.Range(Cells(2, 2), Cells(LastRow, LastCol))) &amp; " 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 &quot;How many unique items max&quot;.
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(&quot;Scripting.Dictionary&quot;)

Dim lastrow As Integer
lastrow = Cells(Rows.Count, &quot;A&quot;).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(&quot;Use Me&quot;)

wstarget.Range(&quot;A1&quot;) = &quot;Faxes&quot;
wstarget.Range(&quot;B1&quot;) = &quot;Other IDs&quot;

'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(&quot;How Many Unique OtherIDs is Max?&quot;, 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 &gt; 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(&quot;A2:A&quot; &amp; CurRow))
        If SubTotal &gt; UniqueTotal Then
            SubTotal = UniqueItems(Range(&quot;A2:A&quot; &amp; CurRow - 1))
            Range(&quot;A1:B&quot; &amp; CurRow - 1).Copy
            Sheets(&quot;Use Me&quot;).Cells.Clear
            Sheets(&quot;Use Me&quot;).Range(&quot;A1&quot;).PasteSpecial xlPasteValues
            Sheets(&quot;Use Me&quot;).Activate
            MsgBox &quot;Use Me Sheet rows contain &quot; &amp; SubTotal &amp; &quot; Unique OtherIDs&quot;
            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.