Appendix Thread 2. ( Codes for other Threads, HTML Tables, etc.)

[DocAElstein]

4th macro, (macro explained in last few posts)

' 4th macro           https://www.excelfox.com/forum/showthread.php/2922-VBA-Count-filtered-rows-in-the-table?p=23270&viewfull=1#post23270                      https://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-2-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=23247&viewfull=1#post23247
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 0 worksheets info, misc temporary stuff
'0a)
Dim WsRes As Worksheet: Set WsRes = ThisWorkbook.Worksheets("Results")
Dim WsFlt As Worksheet: Set WsFlt = ThisWorkbook.Worksheets("Filters")
Dim LcF As Long: Let LcF = WsFlt.Cells.Item(1, WsFlt.Columns.Count).End(xlToLeft).Column
    If Target.Column > LcF Then Exit Sub
Dim LrF As Long: Let LrF = Cells.Item(1).Resize(100, LcF).Find(What:="*", after:=Cells.Item(100, 1), LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False).Row
    If LrF = 1 Then MsgBox prompt:="Nothing to be filterd by": Exit Sub
'0b)(i)
Dim rngFlt As Range: Set rngFlt = Range("A1").Resize(LrF, LcF)
Dim arrFlt() As Variant
 Let arrFlt() = rngFlt.Value2
'0b)(ii)
Dim strFlts As String, Rw As Long, Clm As Long
    For Clm = 1 To LcF '  collecting the filter columns infomation as text
        If Cells.Item(1, Clm) = "" Then ' If the top cell is empy then....
        ' .... This will be an empty column, so do nozjing
        Else
         Let strFlts = strFlts & Cells.Item(1, Clm) ' This puts the header, like  Fname  at the start of the string
            For Rw = 2 To LcF '  loop down the rows in a column containing text
                If Cells.Item(Rw, Clm) = "" Then
                ' a row with a cell with nothing in it for this column under consideration
                Else
                 Let strFlts = strFlts & "," & Cells.Item(Rw, Clm)
                End If
            Next Rw
        ' we are finished with a filter text so..
         Let strFlts = strFlts & "|" '    ..so add an arbritrary thing t
        End If ' this was the check for an empty column indicated by nothing in the top cell
    Next Clm '   On to the next column
 Let strFlts = Left(strFlts, Len(strFlts) - 1)
 ' at this point we have something of this form in strFlts    Fname,rr,ll|FRegion,sh|FCountry

Rem 1
' 1a) Get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1)                                    ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
' Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "Itchy Bollocks.txt"   '
 Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "Itchy BollocksAlan.txt"   '
' Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "data-v9i8Rbfh1ul6_1diL56pb.csv"   '
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundamental type data input...
' Let TotalFile = Space(LOF(FileNum)) '....and wot receives it has to be a string of exactly the right length
'Get #FileNum, , TotalFile
'  Or  http://www.eileenslounge.com/viewtopic.php?p=295782&sid=f6dcab07c4d24e00e697fe4343dc7392#p295782
 Let TotalFile = Input(LOF(FileNum), FileNum)
Close #FileNum
'1b) 1 dimensional array where elements are text file lines
Dim arr1D() As String: Let arr1D() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
'1b(ii) !!!  I need the array of the header later
Dim arrHdrs() As String: Let arrHdrs() = Split(arr1D(0), ",", -1, vbBinaryCompare) ' ###  I don't want to mess with the header later when using the dictionary but I need it to match the filter header to   This array is effectively one containing the values in the first row of the main table.
'1c) put the text file lines into a  dictionary. These lines are not put in as text lines but as 1 dimensional arrray
Dim Dik As Object
 Set Dik = CreateObject("Scripting.Dictionary")
Dim DikCnt As Long
    For DikCnt = 1 To UBound(arr1D())  '                                             ###  Using  (1)  to start with will miss the header at  arr1D(0)
     Dik.Add Key:=DikCnt, Item:=Split(arr1D(DikCnt), ",", -1, vbBinaryCompare) ' Each item in the dictionary is a 1 dimensional array of a single row of the data range
    Next DikCnt
Dim RwsCnt As Long: Let RwsCnt = Dik.Count
Dim strRes As String: Let strRes = "Toltal rows: " & RwsCnt & vbCr & vbLf    '  First bit of info in the final string for output

Rem 2
'2a) Main outer loop  for Filter headers
Dim Flts() As String: Let Flts() = Split(strFlts, "|", -1, vbBinaryCompare)
Dim FltsCnt As Long
    For FltsCnt = 0 To UBound(Flts()) ' ========================================================
    Dim Hdr As String: Let Hdr = Flts(FltsCnt) '
    Debug.Print "Using Filter  " & Hdr & "     -----|---- -_-"
        If InStr(1, Hdr, ",", vbBinaryCompare) = 0 Then
        ' in this case the string in  Hdr  is just the header, and we go no further with any other looping
        Else ' at this point its time to do the innner loop for each of the  "things to look for to filtr out by"
        '2b)   a  Split  by the comma  ,  (that we put in in '0b)(ii)) wiil give all filled cell vaues , and ...
        Dim arrFtbys() As String: Let arrFtbys() = Split(Hdr, ",", -1, vbBinaryCompare)
        '2b(i)    The first element in the last made array will be the Filter header name, which we put in a variable, Hdr
         Let Hdr = arrFtbys(0)  '                    ...
        '2b)(ii)  The first element in the last made array will be the Filter header name, and we try to find that in the main table first row, that tell us where in the main table the column we are interested in is. This way the order of where the columns are in the main table is not important
        Dim MtchRes As Variant
'                         !!!   I got the array of headers   arrHdrs()   earlier    !!!
         Let MtchRes = Application.Match(LCase(Mid(Hdr, 2)), arrHdrs(), 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 " & LCase(Mid(Hdr, 2)) & " in the Table": 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
        Rem 3   Filter out by loop
        Dim FtbyCnt As Long
            For FtbyCnt = 1 To UBound(arrFtbys()) ' ----------Filter out by loop-----------------
            Dim Ftby As String
             Let Ftby = arrFtbys(FtbyCnt)
            Dim Sperm As Variant '   dicloop dicloop dicloop dicloop dicloop dicloop
                '3b dicloop
                For Each Sperm In Dik '  Sperm becomes the next dictionary  Key   Every time this is re done,  there will be less  Sperm  so this line and way of doing it means we are not looking in any found and removed in a previous of this, since they are not in  Dik  anymore
                    If InStr(1, Dik(Sperm)(MtchRes - 1), Ftby, vbBinaryCompare) = 0 Then
                    ' did not find the  "thing to filter out by"
                    Else ' we have a row now that needs to be removed, ans some note of which will be helpful to build the final results
                    Dim FOutDel As String:
                     Let FOutDel = FOutDel & Dik(Sperm)(MtchRes - 1) & vbCr & vbLf ' This will build us a list of matched cell content
                     Dik.Remove Key:=Sperm '  I remove this data line from the dictionary
                    End If
                Next Sperm ' dicloop dicloop dicloop dicloop dicloop dicloop dicloop
             Let FOutDel = Left(FOutDel, Len(FOutDel) - 2)
             Let FOutDel = "Filterd out by """ & Ftby & """" & vbCr & vbLf & FOutDel                      '  ***Add an extra line at the front to say what I am filtering out by
            Debug.Print FOutDel
            Debug.Print "Filtered Out " & UBound(Split(FOutDel, vbCr & vbLf, -1, vbBinaryCompare))        ' ***that  extra line  at the front gives one too many, but as arrays from  Split  start at  indicie/index  0  then the upper bound value is one less than the count of elements,  so these two things cancel themselves out like  -1 +1
             Let RwsCnt = Dik.Count
            Debug.Print "Left is: " & RwsCnt
            Dim FOutCnt As Long
             Let FOutCnt = FOutCnt + UBound(Split(FOutDel, vbCr & vbLf, -1, vbBinaryCompare))
             Let FOutDel = ""
            Next FtbyCnt ' --------------Filter out by loop--------------------------------------
        Debug.Print "Total rows/lines removed for filter " & Hdr & " was " & FOutCnt & vbCr & vbLf
        End If '  we were in a big  If Else  thing where a lot was done
'     Let strRes = strRes & Mid(Hdr, 2) & " filter: " & RwsCnt - FOutCnt & " Left / Filtered " & FOutCnt & vbCr & vbLf
     Let strRes = strRes & Mid(Hdr, 2) & " filter: " & RwsCnt & " Left / Filtered " & FOutCnt & vbCr & vbLf
     Let FOutCnt = 0
    Next FltsCnt ' ==============================================================================

Rem 5 Output
WsRes.Activate
WsRes.Range("A2").Select
 Let WsRes.Range("A2") = strRes

End Sub