Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)

[DocAElstein]

In support of this post.
http://www.excelfox.com/forum/showth...ge40#post12672

Sub DDAllEarlier_Marz172020()  '    http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wsdrs As Worksheet: Set Wsdrs = Worksheets("drivers marz 2020") ' C2:E180     F2:H180
Dim Rngdr1 As Range, Rngdr2 As Range  '
 Set Rngdr1 = Wsdrs.Range("F2:H180"): Set Rngdr2 = Wsdrs.Range("C2:E180") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020
' take each cell in column B range and find it in column D, but find next if the text is already coloured
Dim Rng As Range
    For Each Rng In Rngdr2 '----------------------| looking at each cell in the newest range, trying to find it in the original range
        If Rng <> "" Then
        Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
        Dim FndRng As Range ' FndRng, if found, is in RngDD2 , looking for value in each cell in RngDD1
         Set FndRng = Rngdr1.Find(what:=Rng.Value, After:=Rngdr1.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
            If Not FndRng Is Nothing Then ' we have a match that may or may not have already been found.
                Do While Not FndRng Is Nothing ' ===
                    If FndRng.Interior.ColorIndex = -4142 Then  ' case "virgin "white"" text
                     FndRng.Select
                     Let FndRng.Interior.ColorIndex = ClrIdx
                     Application.Wait (Now + TimeValue("00:00:01"))
                     
                     Rng.Select
                     Let Rng.Interior.ColorIndex = ClrIdx
                     Application.Wait (Now + TimeValue("00:00:01"))
                    
                     Set FndRng = Nothing ' This will force the Loop to end after a succesful match
                    Else ' The cell text is already colored, so try again
                     Set FndRng = Wsdrs.Range("F" & FndRng.Row + 1 & ":H180").Find(what:=Rng.Value, After:=Wsdrs.Range("H180"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)  '   https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
                    End If
                Loop ' looping for next match ======
            Else ' no cell value match
            End If
        Else ' case rng has not text in it
        End If
    Next Rng  ' Each Rng In Rngdr2 ---------------|
End Sub

[DocAElstein]

Test blog post, and function needed for other posts…


http://www.excelfox.com/forum/showth...ge40#post12673

Title….

I have sometimes needed to check for a specific file type in a list of files and folders. Often a simple search for the characters in the extension, ( for example .doc for a Word 2003 file )
I had a more difficult situation where with multiple file types and folders which included parts in the text string which could be mistakenly found in a search fir the extension part.

The logic behind the simple functions below is as follows.
A string is taken in, strIn.
The function contains a list of all extensions being searched for. If an extension is found in the supplied string, then that extension is the string returned by the function. ( The first character in the extension string will always be a . )
If no match is found then the string of
“0” & strIn ' note: that first character is a zero
is retuned

Notes:
In the list, the longest character length extension are at the beginning. This avoids a part of the longer character extension being mistaken as a shorter character extension, since the longest character length extensions will be detected firstly .

Sub TestieGetMyExtension()
 MsgBox prompt:=GetMyExtension("a")
 MsgBox prompt:=GetMyExtension("1394ohci.sys")
 MsgBox prompt:=GetMyExtension("61883.inf_amd64_fb51a2f8b89aa4a7")
 MsgBox prompt:=GetMyExtension("wiaky003.inf_loc")
 MsgBox prompt:=GetMyExtension("acpi.PNF")
 MsgBox prompt:=GetMyExtension("bcmwdidhdpcie.inf_amd64_977dcc915465b0e9")

End Sub
Public Function GetMyExtension(ByVal strIn As String) As String
Dim MyExts() As Variant
 Let MyExts() = Array("inf_loc", "sys.mui", "dll.mui", "sys", "dll", "bin", "cpa", "bag", "xml", "gdl", "cab", "ini", "cat", "inf", "pnf", "gpd", "exe", "sam", "hlp", "ntf", "ppd", "tbl", "icc", "dat", "dpb", "cty", "msc", "xst", "vp", "js")
Dim Stear As Variant
    For Each Stear In MyExts()
    Dim Lenf As Long: Let Lenf = Len(Stear)
        If Len(strIn) > Lenf + 1 Then ' Length of  strIn   must be at least 2 more characters longer than the extension from the array above ,  like  x.sys  so greater than the length of like the length of  .sys  which has the length of   (length of  sys )+1
        Dim LstBt As String
         Let LstBt = Right(strIn, Lenf)
            If "." & UCase(LstBt) = "." & UCase(Stear) Then
             Let GetMyExtension = Stear
             Exit Function ' end of function with sucessful file type find - give file type to  function return string value
            Else
            ' not this file type in last characters
            End If
        Else
        ' then input string is too short to include the current extension string in  Stear
        End If
    Next Stear
 Let GetMyExtension = "0" & strIn ' This allows a simple check for like  If Left(GetMyExstension(kjshdkjs,kiafh_.kjfh, 1)= 0 Then   to determine if we have a file type like we want
End Function

Sub CountMissingFilesFromOriginalInNewList2()
Dim WsDS As Worksheet: Set WsDS = Worksheets("DriverStoreCompareMarz17 2020") '    =ANZAHL2(H3:J4396)     =ANZAHL2(D3:F4396)
Dim RngDS1 As Range, RngDS2 As Range  '
 Set RngDS1 = WsDS.Range("G3:J4396"): Set RngDS2 = WsDS.Range("C3:F4396") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020

Dim Cnt1 As Long, cnt2 As Long, Rng As Range, strRej As String
    For Each Rng In RngDS1
        If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 And Not Left(GetMyExtension(Rng.Value), 1) = "0" Then
        ' Not empty cell  And  No interior colour And  any file extension
         Let Cnt1 = Cnt1 + 1
        Else
            If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 Then
            Let strRej = strRej & Rng.Value & vbCr & vbLf
            Let cnt2 = cnt2 + 1
            Else
            End If
        End If
    Next Rng
 MsgBox prompt:="Missing is  " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not coloured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is  " & cnt2
 Debug.Print "Missing is  " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not colured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is  " & cnt2
End Sub
Sub CountNewFilesFromInNewList2()
Dim WsDS As Worksheet: Set WsDS = Worksheets("DriverStoreCompareMarz17 2020") '    =ANZAHL2(H3:J4396)     =ANZAHL2(D3:F4396)
Dim RngDS1 As Range, RngDS2 As Range  '
 Set RngDS1 = WsDS.Range("G3:J4396"): Set RngDS2 = WsDS.Range("C3:F4396") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020

Dim Cnt1 As Long, cnt2 As Long, Rng As Range, strRej As String, strNew As String
    For Each Rng In RngDS2
        If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 And Not Left(GetMyExtension(Rng.Value), 1) = "0" Then
        ' conditions to be met are   not empty   And   no interior colour   And   any file extension
         Let Cnt1 = Cnt1 + 1
         Let strNew = strNew & Rng.Value & vbCr & vbLf
        Else
            If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 Then
            Let strRej = strRej & Rng.Value & vbCr & vbLf
            Let cnt2 = cnt2 + 1
            Else
            End If
        End If
    Next Rng
 MsgBox prompt:="New is  " & Cnt1 & vbCr & vbLf & "New are  " & strNew
 Debug.Print "New is  " & Cnt1 & vbCr & vbLf & "New are  " & strNew
' MsgBox prompt:="Missing is  " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not coloured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is  " & cnt2
' Debug.Print "Missing is  " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not colured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is  " & cnt2
End Sub

ExplorerBefore DriverStore Comparison Marz 2020.xlsm : https://app.box.com/s/oy8pnuizk6xng1msqlsxho7l8e0bi0t8
Explorer Before DriverStore Comparison Marz 2020.xlsm : https://app.box.com/s/4zx7b8d2gwjix7u68zit6o22x7q0kwm2