VBA for counting specific texts from different ranges.

kalkannaa · Feb 14th 2018

Hi , Urgently need your help on here.

I have an worksheet that having different categories and i need a VBA for counting the texts by category wise. Following is the details

I have A raw with the categories A,B,C, D, E , F and i have the texts like approved, rejected, hold etc... in raw number H. I will have to count these texts by category and texts in the second worksheet like below. Appreciate your help here, thanks...

Categoury	A	B	C
Approved	3	3	1
Rejected	1	1	2
Hold	0	0	1

Mumps · Feb 14th 2018

It would be easier to help and suggest a possible solution if you could post a copy of your file.

Mumps · Feb 15th 2018

Place this formula in cell B2 of the "Summary" sheet: =COUNTIFS(WorkSheet!$H$2:$H$153,Summary!$A2,WorkSheet!$A$2:$A$153,Summary!B$1)
Then drag it across to column G. Next select the range B2:G2 and drag that down to row 14. Please note that the ranges in the formula include the rows down to row 153. Change the 153 to suit your needs.

kalkannaa · Feb 16th 2018

That's Great.
But is it possible to get it done by VBA?

Mumps · Feb 16th 2018

Try:

Code

Sub countCategories()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Summary").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim bottomH As Long
    bottomH = Sheets("Worksheet").Range("H" & Rows.Count).End(xlUp).Row
    Dim status As Range
    Dim cat As Range
    For Each status In Sheets("Summary").Range("A2:A" & LastRow)
        Sheets("Worksheet").Range("A1:H" & bottomH).AutoFilter Field:=8, Criteria1:=status
        For Each cat In Sheets("Summary").Range("B1:G1")
            Sheets("Worksheet").Range("A1:H" & bottomH).AutoFilter Field:=1, Criteria1:=cat
            Sheets("Summary").Cells(status.Row, cat.Column) = Sheets("Worksheet").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
        Next cat
    Next status
    If Sheets("Worksheet").AutoFilterMode = True Then Sheets("Worksheet").AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Display More

Mumps · Feb 17th 2018

Quote

But it is not running automatically. Is there any settings needs to be changed to run it automatically? Kindly advise.

I'm not sure what you mean by this. Can you clarify in detail what you mean by "running automatically"?

Mumps · Feb 18th 2018

Quote

I mean, when I add or change the values in worksheet, the counting's are not updating in summary automatically.

Copy and paste the following macro into the worksheet code module. Do the following: right click the tab for your "Worksheet" sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Change any value in column A or column H and exit the cell and the "Summary" sheet will update automatically. If you want to trigger the macro by only changing column A and not column H, then revise the range: Range("A:A,H:H").

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:A,H:H")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Summary").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim bottomH As Long
    bottomH = Sheets("Worksheet").Range("H" & Rows.Count).End(xlUp).Row
    Dim status As Range
    Dim cat As Range
    For Each status In Sheets("Summary").Range("A2:A" & LastRow)
        Sheets("Worksheet").Range("A1:H" & bottomH).AutoFilter Field:=8, Criteria1:=status
        For Each cat In Sheets("Summary").Range("B1:G1")
            Sheets("Worksheet").Range("A1:H" & bottomH).AutoFilter Field:=1, Criteria1:=cat
            Sheets("Summary").Cells(status.Row, cat.Column) = Sheets("Worksheet").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
        Next cat
    Next status
    If Sheets("Worksheet").AutoFilterMode = True Then Sheets("Worksheet").AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Display More

kalkannaa · Feb 19th 2018

Awesome. Working perfectly. Thank you very much for your help.

Just one thing noticed that mouse cursor browsing for few seconds once I add or change the values in A & H. Is that normal thing?..

Mumps · Feb 19th 2018

It just means that it's taking the macro a few seconds to process the data. The larger the data base, the longer it takes.

kalkannaa · Feb 20th 2018

Noted. My File size is larger & kindly update me if you find anything to solve it in future.
Thank you very much for your fantastic help to solve my issue.

Mumps · Feb 20th 2018

You are very welcome.

**KjBox** · Feb 21st 2018

Try this, it should be faster for a large data set. Macro will only fire if change is made to CATEGORY or STATUS columns and only if neither is blank for the row where data has been entered.

Make sure you copy/paste both procedures!

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x, y, z, Cats, i As Long, ii As Long, iii As Long
    
    If Not Intersect(Target, Columns(1)) Is Nothing _
    Or Not Intersect(Target, Columns(8)) Is Nothing Then
    
        If Cells(Target.Row, 1) <> "" And Cells(Target.Row, 8) = "" _
        Or Cells(Target.Row, 1) = "" And Cells(Target.Row, 8) <> "" _
        Or Cells(Target.Row, 1) = "" And Cells(Target.Row, 8) = "" Then Exit Sub
        
        x = Sheets("Worksheet").Cells(1).CurrentRegion
        z = Sheets("summary").Cells(1).CurrentRegion.Columns(1)
        With CreateObject("scripting.dictionary")
            For i = 2 To UBound(x, 1)
                If Not .exists(x(i, 1)) Then .Add x(i, 1), Nothing
            Next
            Cats = .keys
            QuickSort Cats, LBound(Cats), UBound(Cats)
            ReDim y(1 To 13, 1 To .Count)
        End With
        For i = LBound(Cats) To UBound(Cats)
            For ii = 2 To UBound(x, 1)
                If x(ii, 1) = Cats(i) Then
                    iii = Application.Match(x(ii, 8), z, 0) - 1
                    y(iii, i + 1) = y(iii, i + 1) + 1
                End If
            Next
        Next
        With Sheets("Summary")
            .[b1].Resize(, UBound(Cats) + 1) = Cats
            .[b2].Resize(13, UBound(Cats) + 1) = y
        End With
        MsgBox "Summary successfully updated.", 64, "Completed."
    End If
    
End Sub


Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
  Dim pivot, tmpSwap, tmpLow As Long, tmpHi  As Long
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)


  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi


End Sub

Display More

kalkannaa · Feb 21st 2018

HI, Thanks for your message.
There are some error showing in this code as it is not running. Pls help

[ATTACH=JSON]{"data-align":"none","data-size":"full","title":"Untitled.jpg","data-attachmentid":1199680}[/ATTACH]

**KjBox** · Feb 21st 2018

Sorry, I forgot to say that Cells B1 to G1 on the Worksheet sheet must be filled with header values, for the sample file I simply used Head 2, Head 3, Head 4 etc. The actual values do not matter, nor does it matter if additional columns have headers, as long as CATEGORY is always Column A and STATUS Column H then the code will work.

kalkannaa · Mar 1st 2018

hi
I've added the headers from B1 to G1, but again its not working

**KjBox** · Mar 1st 2018

Are you talking about it not working with the sample file or your actual file?

I am attaching your sample file where the code works fine for me.

If it fails in your actual file then the line that errors indicates that there must be an entry in the Status column of the data worksheet that does not match one of the values in column A of the Summary table. A leading or trailing space in any entry would be seen by Excel as not matching even though the text appears to be the same.

kalkannaa · Mar 8th 2018

Hi, It is working perfectly. Thank you.

Just an inconvenience found that whenever i change the values, there is an notification coming by saying that summary file has been updated. Any way to remove this notification please?

**KjBox** · Mar 8th 2018

You're welcome.

At the very end of the code there is a line

Code

MsgBox "Summary has been successfully updated.", 64, "Completed."

Either delete that line or comment it out (by placing an aposthrophy (') at the start of the line), that will stop the notification.

kalkannaa · Mar 23rd 2018

Fantastic....
Thanks a ton for your help

**KjBox** · Mar 24th 2018

You're welcome

VBA for counting specific texts from different ranges.

Participate now!

Share