Thread: Add like text totals of columns at bottom of column

Will the fruits vary or are they the same as in your example every time?

Another approach. Don't understand what your Fruit Totals column has to do with anything.

Code:

Sub x()
  
Dim nCol1 As Long, nCol2 As Long, rFruits As Range, rng As Range
 
With Sheet1
    nCol1 = .Rows(1).Find(What:="Fruit", LookAt:=xlWhole).Column
    nCol2 = .Rows(1).Find(What:="Fruit Totals", LookAt:=xlWhole).Column
    Set rFruits = Range(Cells(1, nCol1), Cells(Rows.Count, nCol1).End(xlUp))
    rFruits.AdvancedFilter xlFilterCopy, copytorange:=rFruits.End(xlDown)(4), unique:=True
    With rFruits.End(xlDown)(4)
        .Value = "Fruits Total"
        .Offset(, 1) = rFruits.Count - 1
        For Each rng In Range(.Offset(1), .End(xlDown))
            rng.Offset(, 1) = WorksheetFunction.CountIf(rFruits, rng)
            rng = rng & " Total"
        Next rng
    End With
End With
     
End Sub

Sorry Stephen,

I was away for awhile,

The "fruits" are just "dummy" text. I just want to "ADD" the number of times a certain word appears in a cell in a certain column.

I will try both codes out

thanks to both

Krishnakumar,

After looking at your code, I'm not even sure what to do with it, sorry.



Stephen,

I tried running your code and received this error...

Run-time error 91

Object Variable or With block variable not set

on this line

Code:

    nCol1 = .Rows(1).Find(what:="Fruit", LookAt:=xlWhole).Column

any thoughts?

thanks

Hmm, interesting, is there a way to have this automated without having to manually select the range?

Thanks much!

I should have mentioned that I assumed Fruit would be in the first row. Perhaps that is not the case, in which case try this:

Code:

Sub x()
  
Dim nCol1 As Long, nCol2 As Long, rFruits As Range, rng As Range, rFind As Range
 
With Sheet1
    Set rFind = .Cells.Find(What:="Fruit", LookAt:=xlWhole)
    Set rFruits = Range(rFind, Cells(Rows.Count, rFind.Column).End(xlUp))
    rFruits.AdvancedFilter xlFilterCopy, copytorange:=rFruits.End(xlDown)(4), unique:=True
    With rFruits.End(xlDown)(4)
        .Value = "Fruits Total"
        .Offset(, 1) = rFruits.Count - 1
        For Each rng In Range(.Offset(1), .End(xlDown))
            rng.Offset(, 1) = WorksheetFunction.CountIf(rFruits, rng)
            rng = rng & " Total"
        Next rng
    End With
End With
     
End Sub

Hi Stephen,

Yeah, I got the same error unfortunately.

Code:

    Set rFruits = Range(rFind, Cells(Rows.Count, rFind.Column).End(xlUp))

This seems like a tough one.

In that case please attach a sample of your data AS IS.

Stephen,

Here's the workbook you requested.

Thanks,

duugg

duugg - in your original post the heading was "Fruit" but in your attachment was "Fruits" so wasn't picked up. We can't find part of the cell because you have another cell with "Fruits" in it. Btw you also have the word Fruits in your list!

Code:

Sub x()
  
Dim nCol1 As Long, nCol2 As Long, rFruits As Range, rng As Range, rFind As Range
 
With Sheet1
    Set rFind = .Cells.Find(What:="Fruits", LookAt:=xlWhole)
    Set rFruits = Range(rFind, Cells(Rows.Count, rFind.Column).End(xlUp))
    rFruits.AdvancedFilter xlFilterCopy, copytorange:=rFruits.End(xlDown)(4), unique:=True
    Set rFruits = rFruits.Offset(1).Resize(rFruits.Rows.Count - 1)
    With rFruits.End(xlDown)(4)
        .Value = "Fruits Total"
        .Offset(, 1) = rFruits.Count - 1
        For Each rng In Range(.Offset(1), .End(xlDown))
            rng.Offset(, 1) = WorksheetFunction.CountIf(rFruits, rng)
            rng = rng & " Total"
        Next rng
    End With
End With
     
End Sub

Stephen,

Thanks, you got some reputation from me!

Okay, we are very close now

I noticed that the total count type was off by 1, so I looked at the code and took out the part here in red...

Code:

    Set rFruits = rFruits.Offset(1).Resize(rFruits.Rows.Count - 1)

Also, I changed this line of code here...

Code:

With Sheet1

to

Code:

With ActiveSheet

...because it wasn't working initially. I couldn't figure out why at first but then I realized that I had changed the worksheet name. So I managed to figure it out all on my own! I am learning this stuff and it's pretty cool stuff.

After that, it worked great...EXCEPT when there were blank cells. If there's a blank in there, which there will definitely be blanks, I get an error.

2 Things...

Number 1 - Can we modify this code to count the number of blank cells as well? (This will eliminate the bug as well)

Number 2 - Can we modify the code to color all blank cells red?

I think that will do it!

thanks much

duugg

Have changed approach as Advanced Filter doesn't appear to like blanks:

Code:

Sub x()

Dim rFruits As Range, rFind As Range
Dim oDic As Object, sNames() As String, vInput() As Variant
Dim i As Long, nIndex As Long, nCounts() As Long

Set rFind = Cells.Find(What:="Fruits", LookAt:=xlWhole)
Set rFruits = Range(rFind.Offset(1), Cells(Rows.Count, rFind.Column).End(xlUp))
rFruits.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3
vInput = rFruits.Value

ReDim sNames(1 To UBound(vInput, 1))
ReDim nCounts(1 To UBound(vInput, 1))

Set oDic = CreateObject("Scripting.Dictionary")

With oDic
    For i = 1 To UBound(vInput, 1)
        If Not .Exists(vInput(i, 1)) Then
            nIndex = nIndex + 1
            sNames(nIndex) = vInput(i, 1)
            nCounts(nIndex) = nCounts(nIndex) + 1
            .Add vInput(i, 1), nIndex
        ElseIf .Exists(vInput(i, 1)) Then
            nCounts(.Item(vInput(i, 1))) = nCounts(.Item(vInput(i, 1))) + 1
        End If
    Next i
End With

With Cells(Rows.Count, rFind.Column).End(xlUp)(4)
    .Value = "Fruit totals"
    .Offset(, 1).Value = rFruits.Count
    .Offset(1).Resize(nIndex) = WorksheetFunction.Transpose(sNames)
    .Offset(1).Resize(nIndex).SpecialCells(xlCellTypeBlanks) = "Blanks"
    .Offset(1, 1).Resize(nIndex) = WorksheetFunction.Transpose(nCounts)
End With

End Sub