Code:
Option Explicit
' https://www.excelfox.com/forum/showthread.php/2922-VBA-Count-filtered-rows-in-the-table?p=23201&viewfull=1#post23201
Private Sub Worksheet_Change(ByVal Target As Range)
Rem 1 what cell changes don't interest me
If Target.Cells.Count <> 1 Then Exit Sub ' More than one cell changed, for example by pasiting new range in
If Target.Row = 1 Then Exit Sub ' ' Row 1 is always header so of no interst for adding data
If Target.Value = "" Then Exit Sub ' ' If we empty a cell we don't want the macro to do anything
Rem 2 find range to search
Dim Hdr As String, HdRw() As Variant, Lc As Long, Lr As Long, Fc As Long, ClmsCnt As Long
Let Hdr = Cells.Item(1, Target.Column).Value ' we get the header from the first row in the changed column
Let Hdr = LCase(Mid(Hdr, 2)) ' take off the F at the start and change to lower case
Let Lc = Cells.Item(1, Columns.Count).End(xlToLeft).Column ' the last column in the worksheet that has something in the first row, so this will probably
Let ClmsCnt = Cells.Item(1, Lc).CurrentRegion.Columns.Count ' Current region is a square range that includes the cell its applied to and goes as far as there is a spreadsheet boundry of an empty column or row, so the column count of that range will likely tell us how many columns are in our table
Let Fc = Lc - ClmsCnt + 1 ' This should get us the first column of out table
Dim MtchRes As Variant
Let MtchRes = Application.Match(Hdr, Cells.Item(1, Fc).Resize(1, ClmsCnt), 0) ' Either this will return us an VBA error ( it won't actually error ) , or it will give a number of the "position along" of where it makes a match
If IsError(MtchRes) Then MsgBox prompt:="I can't find " & Hdr & "": Exit Sub ' For the case of getting an VBA error returned I must have an incorrect header somewhere, maybe a typo in a header somewhere
Dim SrchClm As Long: Let SrchClm = MtchRes + Fc - 1 ' This should give us the number of the column in the table that I want to search
Let Lr = Cells.Item(Rows.Count, SrchClm).End(xlUp).Row ' This should return the last used row in that column
If Cells.Item(Lr, SrchClm) = "" Then Let Lr = Cells.Item(Lr, SrchClm).End(xlUp).Row ' This sia bit of a bodge, and I am not sure yet why i nned this, but it appears that I first find the last row in the table if the last row is empty for this column. Strange, but empirically it seems doing it again gets over this problem. I also saw that doing it again if I did get the correct last row with something in it, then doing it again will get me down to row 1. So it looks like perhaps it initially gety the end of the table. That is OK if the column to search has a last table entry. otherwise doing it again gets me down to the löast used row for that column
Dim SrchRng As Range: Set SrchRng = Cells.Item(2, SrchClm).Resize(Lr - 1, 1) ' This will be the column range to search
Dim arrSrch() As Variant: Let arrSrch() = SrchRng.Value ' gets an array of the search range
Rem 3 Get array of matches by clever way that only Alan, The Fuhrer, knows about
Dim arrSrchF() As Variant
Let arrSrchF() = Evaluate("=IF({1},SEARCH(" & """" & Target.Value & """" & "," & SrchRng.Address & "))")
Rem 4 Get results from arrHits()
Dim TRws As Long, HitRws As Long, strHits As String
Dim Cnt As Long ' arrSrchF() will look like this, https://i.postimg.cc/gJQ121Wq/arr-Srch-F.jpg , each element has something similar to the .Match result, so we can use that to see if we got a match or not
For Cnt = 1 To UBound(arrSrchF(), 1)
If IsError(arrSrchF(Cnt, 1)) Then
' if error than no hit
Else
Let strHits = strHits & arrSrch(Cnt, 1) & vbCr & vbLf ' This gives the actual value of a hit, or rather adds it to a long text string for the output
End If
Next Cnt
Let strHits = Left(strHits, Len(strHits) - 2) ' This takes off the last vbDr & vbLf which we doin't need
Rem 5 Final output
Dim arrFnd() As String: Let arrFnd() = Split(strHits, vbCr & vbLf, -1, vbBinaryCompare) ' This splits the output string by the line seperator, and returns a 1 dimansional array where each elemnt is effectively a matched row value. The number of elements of this array will be a convenient way on the next line to get the numkber of row match results we got
Let strHits = Hdr & " Filter by " & Target.Value & " will get " & UBound(arrFnd()) + 1 & " rows " & vbCr & vbLf & vbCr & vbLf & strHits & vbCr & vbLf
Let strHits = strHits & vbCr & vbLf & "Total rows in " & Hdr & " column was " & Lr - 1
MsgBox prompt:=strHits: Debug.Print strHits
End Sub
Reply With Quote
Bookmarks