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
        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
            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:

After Faxes Runs

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
        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("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:

After Remove Dups

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

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
End Sub


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
            faxNumsDict.Add Key:=theFaxNum, Item:=New Collection
        End If
        ' Now update the collection
        faxNumsDict.Item(theFaxNum).Add theOtherId
    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.


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.