[SOLVED] Add like text totals of columns at bottom of column

duugg · #1 07-02-2009, 01:10 PM

Hello,

Note that the "Fruit" and "Fruit Totals" column letter position will always be different every time I run the macro, so I would like the macro to find these columns by name rather than by column letter.

I'd like a macro that adds the total number of fruits in the "Fruit" column by looking doing 2 things...

1. Add the total number of "Fruits" in the "Fruit" column, find the bottom-most row of data in the "Fruit" column, go down 2 rows, and create the text named "Fruits Total"

2. In the cell directly to the right of "Fruits Total" put the value of the total number of fruits in this cell (which will be in the "Fruit Totals" column)

3. Add the total number of "Apples" in the "Fruit" column, find the bottom-most row of data in the "Fruit" column, go down 2 rows, and create the text named "Apples Total"

4. In the cell directly to the right of "Apples Total" put the value of the total number of apples in this cell (which will also be in the "Fruit Totals" column)

5. Repeat steps 3 & 4 for the other fruits

Best to show you an example

Code:

Col "x"?           Col "x"?
Fruit	      Fruit Totals
Apple	
Apple	
Orange	
Pear	
Grape	
Cherry	
Cherry	
Apple	
Pear	
Orange	
Pear	
Grape	
Cherry	
Cherry	
	
Fruits Total         14
Apple Totals	3
Orange Totals	2
Grape Totals	2
Pear Totals	3
Cherry Totals	4

StephenR · #2 07-02-2009, 02:03 PM

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

Krishnakumar · #3 07-02-2009, 02:10 PM

Hi,

Select the range and run the VBA.

Code:

Sub kTest()
Dim d, v, k
d = Selection.Value
With CreateObject("scripting.dictionary")
    .comparemode = 1
    For Each v In d
        If Not IsEmpty(v) Then
            If Not .exists(v) Then
                .Add v, 1
            Else
                .Item(v) = .Item(v) + 1
            End If
        End If
    Next
    k = Array(.keys, .items)
End With
With Selection.Offset(Selection.Rows.Count + 1)
    .Resize(UBound(k(1)) + 1, 2).Value = Application.Transpose(k)
    .Resize(UBound(k(1)) + 1).Value = Evaluate(.Resize(UBound(k(1)) + 1).Address & "&"" Totals""")
End With
End Sub

StephenR · #4 07-02-2009, 02:26 PM

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

duugg · #5 07-02-2009, 05:40 PM

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

duugg · #6 07-02-2009, 09:13 PM

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

Krishnakumar · #7 07-02-2009, 10:25 PM

Hi,

Quote:

Krishnakumar,

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

See the attachment.

duugg · #8 07-02-2009, 11:20 PM

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

Thanks much!

StephenR · #9 07-03-2009, 05:27 AM

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

duugg · #10 07-03-2009, 08:47 AM

Hi Stephen,

Yeah, I got the same error unfortunately.

Code:

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

StephenR · #11 07-03-2009, 09:24 AM

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

duugg · #12 07-03-2009, 11:22 PM

Stephen,

Here's the workbook you requested.

Thanks,

duugg

StephenR · #13 07-04-2009, 07:22 AM

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

duugg · #14 07-04-2009, 12:07 PM

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)

StephenR · #15 07-04-2009, 12:44 PM

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

Welcome to the Excel Forum

Forum Statistics