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

Stephen,

This is awesome!

Geez, I hate when, after I see something work exactly as intended, I realize a problem that I hadn't realized before. Here's the problem...I plan on using this awesome code for several columns (see question 3 below) and some columns are right next to each other, so, using the macro as is would cause data to overlap
But this problem made me realize that I would rather have the data on a new worksheet anyways (question 1, below).


How hard would it be to modify this "awesome" code to do this...

1. Instead of putting all this info underneath the bottom-most row of data, create a new worksheet named "Totals" and put all this data starting at the first blank cell in column a instead

2. Put the focus back to the worksheet that the macro started on

3. Do I have to use this whole block of code for each column or can I add columns to the existing code?

Something like this in red below?

Set rFind = Cells.Find(What:="Fruits", "Vegetables", LookAt:=xlWhole)

4. Each new column I run the macro on, it would also go to the same newly created worksheet named "Totals" and would be below the bottom-most row of data.

So let's say I ran the first macro named "Fruits".
All totals data would go to the new worksheet named "Totals".
Fruit names would be in column A
Fruit totals would be in column B

And let's say after running the "Fruits" macro, it created 10 rows of text in columns A and B, this would make row 11 the first blank row.

Then, I run same macro, but modifying it for the "Vegetables" column. After running the "Vegetables" macro, all data from this macro would also go to the new "totals" worksheet, which would put the data starting at the first blank row in column a, in this case, row 11.

Whew, I really believe I'll be done after this because ALL data from all my columns will be in one centralized place.

Thank you sooooooooo much for helping me with this Stephen! I'm creating my own fireworks with this macro today!



Thanks again!

duugg

This code loops through an array of search items which you can adjust.

Sub x()

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

If Not SheetExists("Totals") Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Totals"
Sheet1.Activate

vItems = Array("Fruits", "Vegetables")  '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 = 3
    On Error GoTo 0
    
    ReDim vTotals(1 To UBound(vInput, 1), 1 To 2)
               
    With CreateObject("Scripting.Dictionary")
        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

Hi Stephen,

Thanks for the reply

I'm getting this error message:

Run-Time Error 91:

Object Variable or With Block variable not set

After pressing debug, this line of code was highlighted yellow

    Set rData = Range(rFind.Offset(1), Cells(Rows.Count, rFind.Column).End(xlUp))

It does create a "Totals" worksheet even after the error but doesn't bring the focus back to the worksheet the macro started on.


thanks,

duugg

If you remember, that's probably because the value was not found on the sheet so you can add the middle line below to exit the code rather than erroring.

Set rFind = Cells.Find(What:=vItems(j), LookAt:=xlWhole)
If rFind is Nothing Then Exit Sub
Set rData = Range(rFind.Offset(1), Cells(Rows.Count, rFind.Column).End(xlUp))

Currently, the macro stops once it gets to the first blank cell in its respective column.

No, it goes to the last used cell in the Fruits/Veg column.

I need the macro to change it's stopping point from the first blank cell in each column to instead stop counting once it is equal to the bottom-most row cell with data in the "Cust Num" column...

So if there are fruits below that row ignore them?

duugg- would you like to leave it for 24 hours and think long and hard about what you need, because I can't keep changing this code indefinitely?!

Hi Stephen,


I can say for sure that there will NEVER be a text count in any column that's lower than the bottom-most row of data in the customer column.


It's funny you say that about thinking about the code for 24 hours..because I noticed that in the fruits column for example, BANANA and banana and Banana were counted seperately (in 3 rows on the totals worksheet).

I was going to try putting in some code BEFORE this macro was run that changes all text in the criteria columns (Fruits, Vegetables, etc) to UPPERCASE (except header row) but, if the code for counting BANANA, banana & Banana as the same text in a column is fairly simple, then, putting that in would be fantastic.

So, at a minimum, if you could at least change the count thing to match the "customer number" column, that would be great.

If the code to count all cases of text for the same word as one is fairly simple, that would FINISH THIS. Otherwise, I will convert all relevant columns to uppercase before this macro.

WHATEVER YOU PROVIDE IN THE NEXT REPLY, I WILL REPLY TO MARK THIS THREAD AS CLOSED. (unless I get an error of course, but I will first investigate and try to fix myself).

I don't need 24 hours, promise that really is it Stephen.



P.S. On the positive side, I truly believe that my questions along with your expertise/replies in the several posts to this thread will really help a lot of people. It has already received a lot of views. Seeing the progression of a good macro like this gives novices like me and others a great perspective on the development of a good macro. Of course, this is something you may no longer understand as you are now a PRO lol.

My sincere and infinite thanks for this "gold macro"

I can say for sure that there will NEVER be a text count in any column that's lower than the bottom-most row of data in the customer column.

In that case, I can't see what needs changing.

You can add the second line below to ignore case, but you'll have to check spelling (banana has two 'n's):

With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare

Hi Stephen,

The case problem was fixed, thank you for that.

FYI - My last problem only happened if there were blank cells in these 2 columns ("Fruits" or "Vegetables")

For example, if the last text entry in the "Fruits" column was "Cherry" on row 10, but I had customer numbers in the "Customer Number" column going down to row 15, then 5 "Fruit" blanks wouldn't be reported in the "totals" worksheet.

I tried this code, to highlight all cells in my vegetable column so that I can "find and replace" all blanks with "BLANK CELL", but it didn't work...

    Cells.Find(What:="customer number", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.LargeScroll Down:=1
    Range("O1:P1261").Select
    Range("O1261").Activate
    Selection.Replace What:="", Replacement:="BLANK CELL", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
    Range("O3").Select
End Sub

But, as promised, I will closed the thread.

Thanks again

duugg - I stand corrected and now see what you mean. Have amended the code to, I hope, do what you want.

Sub x()

Dim rData As Range, rFind As Range, rCust As Range
Dim vTotals() As Variant, vInput() As Variant, vItems As Variant
Dim i As Long, j As Long, n As Long, nCust As Long

Application.ScreenUpdating = False

If Not SheetExists("Totals") Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Totals"
Sheet1.Activate
Set rCust = Cells.Find(What:="Cust Num", LookAt:=xlWhole)
If Not rCust Is Nothing Then nCust = rCust.End(xlDown).Row

vItems = Array("Fruits", "Vegetables")  'Items to be searched -  adjust to suit

For j = LBound(vItems) To UBound(vItems)
    Set rFind = Cells.Find(What:=vItems(j), LookAt:=xlWhole)
    If rFind Is Nothing Then Exit Sub
    Set rData = Range(rFind.Offset(1), Cells(nCust, rFind.Column))
    vInput = rData.Value
    
    On Error Resume Next
        rData.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3
    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

Stephen,


AHHHHHHHHHHHHHHHH !!!!!!!!!!!

What else can I say but............

ABSOLUTE PERFECTION!

Now I can enjoy the rest of my day without trying to figure out a workaround...

I'm sure this thread will help others as well

Many Many Thanks!