This code works great for counting text for 2 or more rows, but I get a "RunTime Error 13, type mismatch" error when there is only one row of data.

[VBAProIWish]

Hello All,

This code works great for counting text for 2 or more rows, but I get a "RunTime Error 13, type mismatch" error when there is only one row of data.

Sub aaa_test_macro_01()
 
Sheets("Cans, O").Select


'CREATE A WORKSHEET NAMED "TOTALS" AND PUT TEXT TOTALS IN THERE
'This macro counts the number of times a word appears in selected columns and then creates
'a totals column with the text count of each column


'Sub Add_Text_Totals()
Dim rData As Range, rFind As Range
Dim vTotals() As Variant, vInput() As Variant, vItems As Variant
Dim i As Long, j As Long, n As Long


Application.ScreenUpdating = False
Set DataSheet = ActiveSheet


If Not SheetExists("Totals") Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Totals"
DataSheet.Activate
vItems = Array("Shipping Status")  'Items to be searched -  adjust to suit


For j = LBound(vItems) To UBound(vItems)
    Set rFind = Cells.Find(what:=vItems(j), LookAt:=xlWhole)
    Set rData = Range(rFind.Offset(1), Cells(Rows.Count, rFind.Column).End(xlUp))




    vInput = rData.Value
    
    On Error Resume Next
        rData.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 0
    On Error GoTo 0
    
    ReDim vTotals(1 To UBound(vInput, 1), 1 To 2)
               
    With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
        For i = 1 To UBound(vInput, 1)
            If Not .exists(vInput(i, 1)) Then
                n = n + 1
                vTotals(n, 1) = vInput(i, 1)
                vTotals(n, 2) = vTotals(n, 2) + 1
                .Add vInput(i, 1), n
            ElseIf .exists(vInput(i, 1)) Then
                vTotals(.item(vInput(i, 1)), 2) = vTotals(.item(vInput(i, 1)), 2) + 1
            End If
        Next i
    End With
    
    With Sheets("Totals").Cells(Rows.Count, 1).End(xlUp)(2)
        .Value = vItems(j) & " totals"
        .Offset(, 1).Value = rData.Count
        .Offset(1).Resize(n, 2) = vTotals
        On Error Resume Next
            .Offset(1).Resize(n).SpecialCells(xlCellTypeBlanks) = "Blanks"
        On Error GoTo 0
        .Columns.AutoFit
    End With
    
    n = 0
    Erase vTotals
    Erase vInput
    Set rFind = Nothing
    Set rData = Nothing
Next j


Application.ScreenUpdating = True

End Sub


Function SheetExists(SName As String) As Boolean


On Error Resume Next
SheetExists = CBool(Len(Sheets(SName).Name))


End Function

Is there a way to modify this code so that it works when there is one row of data as well?

Thanks much!