VBA: Unique items in a column across several worksheets

Question

So I have a column, say Expenses, which contains the name of an expense being claimed. I have such a list for each month, each month being a separate sheet. The goal is to get a list of unique expense names into a new sheet, which will later be used for totals calculations.

Because I'd like to compare different periods, the amount of months (worksheets) to examine is variable, as is the number of items listed, so I'd like to keep this as flexible as possible.

I have this code so far, but it only seems to crash. I'm guessing it has to do with some sheets not holding values, but I'm not sure.

Sub FindExpenses()

Dim ws As Worksheet
Dim ExpenseNames As New Collection

' Find for each sheet (month)
For Each ws In ActiveWorkbook.Worksheets

    Dim itm
    Dim i As Long
    Dim CellVal As Variant

    ' Go through each row of column F looking for uniques
    For i = 2 To Rows.Count
    On Error Resume Next

        CellVal = ws.Range("F" & i).Value
        On Error Resume Next
        ExpenseNames.Add CellVal, Chr(34) & CellVal & Chr(34)
        On Error GoTo 0
    Next i

Next

' Print out to separate sheet (figure out how to)
For Each itm In ExpenseNames 
    Debug.Print itm
Next

End Sub

Could you please help me identify unique items in a column across several worksheets to then send it to it's own column in another sheet? Any help would be greatly appreciated. Thank you in advance!

Answer 1

Excel freezes, because you are using Rows.Count in your code. Thus, it loops up to 1048576 for every worksheet in your workbook. Try to get the last used row and to loop up to it.

This is a way to check the last used row in column F in worksheet ws :

lastRow (ws.Name, 6)

---

Function lastRow(Optional strSheet As String, Optional columnToCheck As Long = 1) As Long

    Dim shSheet As Worksheet

    If strSheet = vbNullString Then
        Set shSheet = ActiveSheet
    Else
        Set shSheet = Worksheets(strSheet)
    End If

    lastRow = shSheet.Cells(shSheet.Rows.Count, columnToCheck).End(xlUp).Row

End Function