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

duugg · #16 07-04-2009, 02:26 PM

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?

Code:

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

StephenR · #17 07-05-2009, 02:39 PM

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

Code:

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

duugg · #18 07-06-2009, 09:51 AM

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

Code:

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

StephenR · #19 07-06-2009, 11:30 AM

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.

Code:

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))

duugg · #20 07-06-2009, 12:25 PM

Hi Stephen,

Wow, this code stuff requires some patience...whew

1 self-fix and 1 "duugg oversight"

The "duugg oversight" - All columns that I'll be counting text on (ie Fruits, Vegetables, etc), obviously need to "stop counting" at some point. Currently, the macro stops once it gets to the first blank cell in its respective column.

MY Fault for not telling you this...but 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...

Using this as an example...

Code:

Row 1	Cust Num	  Fruits	Vegetables
Row 2	151	  Banana	 Squash
Row 3	285		 Green Beans
Row 4	2655	  Cherry 	 Green Beans
Row 5	a41		 Potato
Row 6	411b	  Banana	 Squash
Row 7	2656	  Banana	
Row 8	a42		
Row 9	a43

StephenR · #21 07-06-2009, 02:31 PM

Quote:

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.

Quote:

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?!

duugg · #22 07-06-2009, 03:05 PM

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"

StephenR · #23 07-07-2009, 06:37 AM

Quote:

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):

Code:

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

duugg · #24 07-07-2009, 02:25 PM

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...

Code:

    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

StephenR · #25 07-08-2009, 08:52 AM

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

Code:

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

duugg · #26 07-08-2009, 11:03 AM

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!

Welcome to the Excel Forum

Forum Statistics