-
In support of this Thread
http://www.excelfox.com/forum/showth...ge29#post12481
Code:
Sub FileTypesHereDoubleDriverFull_Clamers_SquareBrackets()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("F5:G670")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Dim Inf2 As Long, Ini2 As Long, Cat2 As Long, Gpd2 As Long, Xml2 As Long, Gdl2 As Long
Dim Ddl3 As Long, Sys3 As Long, Bin3 As Long, Cpa3 As Long, Vp3 As Long, Els3 As Long
Dim Inf3 As Long, Ini3 As Long, Cat3 As Long, Gpd3 As Long, Xml3 As Long, Gdl3 As Long
Dim Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Dim Js2 As Long, Dpd2 As Long, Ppd2 As Long, Cab2 As Long, Bag2 As Long, Exe2 As Long
Dim Js3 As Long, Dpd3 As Long, Ppd3 As Long, Cab3 As Long, Bag3 As Long, Exe3 As Long
Dim Dpb As Long
Dim Dpb2 As Long
Dim Dpb3 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
'If Left(RngStr.Value, 3) = "C:\" And InStr(4, RngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Sys3 = Sys3 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ddl3 = Ddl3 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Bin3 = Bin3 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cpa3 = Cpa3 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Vp3 = Vp3 + 1
' Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Case "INF"
Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Inf3 = Inf3 + 1
Case "INI"
Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ini3 = Ini3 + 1
Case "CAT"
Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cat3 = Cat3 + 1
Case "GPD"
Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Gpd3 = Gpd3 + 1
Case "XML"
Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Xml3 = Xml3 + 1
Case "GDL"
Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Gdl3 = Gdl3 + 1
' Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Case "JS"
Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Js3 = Js3 + 1
Case "DPD"
Let Dpd = Dpd + 1: If rngStr.Font.Color <> 0 Then Let Dpd2 = Dpd2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Dpd3 = Dpd3 + 1
Case "PPD"
Let Ppd = Ppd + 1: If rngStr.Font.Color <> 0 Then Let Ppd2 = Ppd2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ppd3 = Ppd3 + 1
Case "CAB"
Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cab3 = Cab3 + 1
Case "BAG"
Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Bag3 = Bag3 + 1
Case "EXE"
Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Exe3 = Exe3 + 1
' DPB
Case "DPB"
Let Dpb = Dpb + 1: If rngStr.Font.Color <> 0 Then Let Dpb2 = Dpb2 + 1: If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Dpd3 = Dpd3 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value
Let Els = Els + 1:: If rngStr.Font.Color <> 0 Then Let Els2 = Els2 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output
Debug.Print "sys " & Sys & " (" & Sys2 & ") [" & Sys3 & "]"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ") [" & Ddl3 & "]"
Debug.Print "bin " & Bin & " (" & Bin2 & ") [" & Bin3 & "]"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ") [" & Cpa3 & "]"
Debug.Print "vp " & Vp & " (" & Vp2 & ") [" & Vp3 & "]"
Debug.Print "els " & Els & " (" & Els2 & ")"
' Inf As Long, Ini As Long, Cat As Long, Gpd As Long, Xml As Long, Gdl As Long
Debug.Print "inf " & Inf & " (" & Inf2 & ") [" & Inf3 & "]"
Debug.Print "ini " & Ini & " (" & Ini2 & ") [" & Ini3 & "]"
Debug.Print "cat " & Cat & " (" & Cat2 & ") [" & Cat3 & "]"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ") [" & Gpd3 & "]"
Debug.Print "xml " & Xml & " (" & Xml2 & ") [" & Xml3 & "]"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ") [" & Gdl3 & "]"
' Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long
Debug.Print "js " & Js & " (" & Js2 & ") [" & Js3 & "]"
Debug.Print "dpd " & Dpd & " (" & Dpd2 & ") [" & Dpd3 & "]"
Debug.Print "cab " & Cab & " (" & Cab2 & ") [" & Cab3 & "]"
Debug.Print "bag " & Bag & " (" & Bag2 & ") [" & Bag3 & "]"
Debug.Print "ppd " & Ppd & " (" & Ppd2 & ") [" & Ppd3 & "]"
Debug.Print "exe " & Exe & " (" & Exe2 & ") [" & Exe3 & "]"
' DPB
Debug.Print "dpb " & Dpb & " (" & Dpb2 & ") [" & Dpb3 & "]"
Debug.Print " Total " & Sys + Ddl + Bin + Cpa + Vp + Els + Inf + Ini + Cat + Gpd + Xml + Gdl + Js + Dpd + Cab + Bag + Ppd + Exe + Dpb & " (" & Sys2 + Ddl2 + Bin2 + Cpa2 + Vp2 + Els2 + Inf2 + Ini2 + Cat2 + Gpd2 + Xml2 + Gdl2 + Js2 + Dpd2 + Cab2 + Bag2 + Ppd2 + Exe2 + Dpb2 & ") [" & Sys3 + Ddl3 + Bin3 + Cpa3 + Vp3 + Els3 + Inf3 + Ini3 + Cat3 + Gpd3 + Xml3 + Gdl3 + Js3 + Dpd3 + Cab3 + Bag3 + Ppd3 + Exe3 + Dpb3 & "]"
End Sub
-
In support of this post
http://www.excelfox.com/forum/showth...ge29#post12484
Code:
' Macro to color text of matching files in two worksheets
Sub CompareDriverFilesCommandIndrivers() '
Rem 0
If ActiveSheet.Name <> "PowerShell" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim Wsdr As Worksheet, WsCmd As Worksheet
Set Wsdr = Worksheets("drivers"): Set WsCmd = Worksheets("PowerShell")
Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range
Dim CelVl As String: Let CelVl = SrchForCel.Value
'If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file and not a Folder name with a . in it
If Len(CelVl) > (InStr(4, CelVl, ".", vbBinaryCompare) + 3) Then
' case a lot of characters after the . so we probably have a Folder name
Else
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\")
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=drivers!D4:drivers!E180") '
Dim FndCel As Range
Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=drivers!D4"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsCmd.Activate: SrchForCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
Wsdr.Activate: FndCel.Select
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
End If ' end of check that the string with a . in it was a file
Else ' case no file string in cell
End If
Next SrchForCel
End Sub
-
In support of this Post
http://www.excelfox.com/forum/showth...ge29#post12485
Code:
' Macro to color text of matching files in two worksheets
Sub CompareDriverFilesCommandInDriverStore() '
Rem 0
If ActiveSheet.Name <> "PowerShell" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDS As Worksheet, WsCmd As Worksheet
Set WsDS = Worksheets("DriverStore"): Set WsCmd = Worksheets("PowerShell")
Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range
Dim CelVl As String: Let CelVl = SrchForCel.Value
'If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file and not a Folder name with a . in it
If Len(CelVl) > (InStr(4, CelVl, ".", vbBinaryCompare) + 3) Then
' case a lot of characters after the . so we probably have a Folder name
Else
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\")
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DriverStore!D5:DriverStore!F4437") '
Dim FndCel As Range
Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsCmd.Activate: SrchForCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
WsDS.Activate: FndCel.Select
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
End If ' end of check that the string with a . in it was a file
Else ' case no file string in cell
End If
Next SrchForCel
End Sub
-
In support of these threads.
http://www.excelfox.com/forum/showth...ge30#post12493
http://www.excelfox.com/forum/showth...ge33#post12597
Code:
'
Sub CompareDriverFilesDeviceManagerInDoubleDriverAllList2()
Rem 0
If ActiveSheet.Name <> "DeviceManagerProperties" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDMP As Worksheet, WsDDA As Worksheet
Set WsDMP = Worksheets("DeviceManagerProperties"): Set WsDDA = Worksheets("DDAllBefore")
Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range
Dim CelVl As String: Let CelVl = SrchForCel.Value
If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\")
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DDAllBefore!F5:DDAllBefore!G670") ' WsDDA.Range("=F5:G670")
Dim FndCel As Range
Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DDAllBefore!F5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDMP.Activate: SrchForCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
WsDDA.Activate: FndCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub
For
http://www.excelfox.com/forum/showth...ge30#post12492
-
In support of this post:
http://www.excelfox.com/forum/showth...ge36#post12628
Note a new modification... for the case of when a cell in Device Manger is coloured ( indicating a match to drivers ) but the case when no match is found in DriverStore. We then need to make the underline which we are using as an indication for a match to drivers
Code:
Else ' No match was found - the thing in the cell in this worksheet is not in the other worksheet
If SrchForCel.Font.Color <> 0 Then Let SrchForCel.Font.Underline = True 'we need an extra check for if the cell is already coluoured indicating a match in drivers
End If
Code:
Sub CompareDriverFilesDeviceManagerInDriverStore2() '
Rem 0
If ActiveSheet.Name <> "DeviceManagerProperties" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDMP As Worksheet, WsDrSt As Worksheet
Set WsDMP = Worksheets("DeviceManagerProperties"): Set WsDrSt = Worksheets("DriverStore")
Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range. Each should be a cell in DeviceManagerProperties
Dim CelVl As String: Let CelVl = SrchForCel.Value
If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\") --- the characters count left over after the subtraction is equal to the character length of the file name
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DriverStore!D5:DriverStore!F4437") '
Dim FndCel As Range: Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'4a) but we might already have a match,
If SrchForCel.Font.Color <> 0 Then ' Extra things to do if we already found the cell value in drivers
Let ClrIdx = SrchForCel.Font.ColorIndex ' this will make the line below to colorthe text of this cell redundant but will ensure that we use the same color in the DriverStore worksheet rather than the randomly generated one
WsDMP.Activate: SrchForCel.Select
Let SrchForCel.Font.Underline = True
Else
End If
'Debug.Print FndCel.Value
Do While Not FndCel Is Nothing ' Start Find next loop ======
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDMP.Activate: SrchForCel.Select ' This worksheet will be colured
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
Let SrchForCel.Font.Italic = True
WsDrSt.Activate: FndCel.Select ' the other workseet
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Set FndCel = Application.Range("=DriverStore!D" & FndCel.Row + 1 & ":DriverStore!F4437").Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!F4437"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) '
Loop ' End Find next loop =================================
Else ' No match was found - the thing in the cell in this worksheet is not in the other worksheet
If SrchForCel.Font.Color <> 0 Then Let SrchForCel.Font.Underline = True 'we need an extra check for if the cell is already coluoured indicating a match in drivers
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub
-
In support of this Post
http://www.excelfox.com/forum/showth...ge39#post12659
Code:
Sub FileTypesHereInDeviceManagerPropertiesUndDriverStoreUnddrivers2() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page39#post12659 http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page18#post12360
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D2:F264")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Dim Ddl3 As Long, Sys3 As Long, Bin3 As Long, Cpa3 As Long, Vp3 As Long, Els3 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If Left(rngStr.Value, 3) = "C:\" And InStr(4, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(4, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1
If rngStr.Font.Italic = True Then Let Sys2 = Sys2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Sys3 = Sys3 + 1
Case "DLL"
Let Ddl = Ddl + 1
If rngStr.Font.Italic = True Then Let Ddl2 = Ddl2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ddl3 = Ddl3 + 1
Case "BIN"
Let Bin = Bin + 1
If rngStr.Font.Italic = True Then Let Bin2 = Bin2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Bin3 = Bin3 + 1
Case "CPA"
Let Cpa = Cpa + 1
If rngStr.Font.Italic = True Then Let Cpa2 = Cpa2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cpa3 = Cpa3 + 1
Case "VP"
Let Vp = Vp + 1
If rngStr.Font.Italic = True Then Let Vp2 = Vp2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Vp3 = Vp3 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value
Let Els = Els + 1
If rngStr.Font.Italic = True Then Let Els2 = Els2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Els3 = Els3 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output
Debug.Print "sys " & Sys & " (" & Sys2 & ") [" & Sys3 & "]"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ") [" & Ddl3 & "]"
Debug.Print "bin " & Bin & " (" & Bin2 & ") [" & Bin3 & "]"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ") [" & Cpa3 & "]"
Debug.Print "vp " & Vp & " (" & Vp2 & ") [" & Vp3 & "]"
Debug.Print "els " & Els & " (" & Els2 & ") [" & Els3 & "]"
Debug.Print "Totals " & Sys + Ddl + Bin + Cpa + Vp + Els & " (" & Sys2 + Ddl2 + Bin2 + Cpa2 + Vp2 + Els2 & ") [" & Sys3 + Ddl3 + Bin3 + Cpa3 + Vp3 + Els3 & "]"
End Sub
-
In support of this Thread answer
http://www.eileenslounge.com/viewtop...=34247#p265646
Code:
Option Explicit
Sub DDAllEarlier_Marz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim WsDDD As Worksheet: Set WsDDD = Worksheets("DDAllEarlier_Marz17")
Dim RngDD As Range, rngDB As Range ' =ANZAHL2(B2:B550) 255 =ANZAHL2(D2:D550) 366
Set RngDD = WsDDD.Range("B2:B550"): Set rngDB = WsDDD.Range("D2:D550")
' 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 RngDD '----------------------|
If Rng <> "" Then
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim FndRng As Range
Set FndRng = rngDB.Find(what:=Rng.Value, After:=rngDB.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.Font.Color = 0 Then ' case "virgin black" text
FndRng.Select
Let FndRng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))
Rng.Select
Let Rng.Font.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 = WsDDD.Range("D" & FndRng.Row + 1 & ":D550").Find(what:=Rng.Value, After:=WsDDD.Range("D550"), 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 RngDD ---------------|
End Sub
-
In support of these posts
http://www.excelfox.com/forum/showth...ge40#post12669
http://www.eileenslounge.com/viewtop...=34247#p265646
Code:
' _ Marz 2020
Sub DeviceManagerPropertiesMarz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim WsDMP As Worksheet: Set WsDMP = Worksheets("DeviceManagerProperties")
Dim rngDMP1 As Range, rngDMP2 As Range ' B1:F550 G1:J550
Set rngDMP1 = WsDMP.Range("B5:F550"): Set rngDMP2 = WsDMP.Range("G5:J550")
' take each cell in range for original DMP and find it in range for new DMP but find next if the interior is already coloured
Dim Rng As Range
For Each Rng In rngDMP1 '----------------------|
If Rng <> "" Then
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim FndRng As Range
Set FndRng = rngDMP2.Find(what:=Rng.Value, After:=rngDMP2.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 already has background color, so try again from next row
Set FndRng = WsDMP.Range("G" & FndRng.Row + 1 & ":J550").Find(what:=Rng.Value, After:=WsDMP.Range("J550"), 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 '------------------------------------|
End Sub
ExplorerBefore DeviceManager Earlier and Marz17 2020.xlsm : https://app.box.com/s/gsgwwbqggel397ufnruegjyfst51p3g6
-
In support of this Post
http://www.excelfox.com/forum/showth...ge40#post12670
Code:
Option Explicit
' Marz 2020
Private Sub FileTypesHere_And_MaybeAlsoInDeviceManager()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D4:E300") 'Set Rng = Ws.Range("F4:G300") ' Set Rng = Ws.Range("D4:E75")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long
Dim Bag2 As Long, Xml2 As Long, Js2 As Long, Gdl2 As Long, Cab2 As Long, Ini2 As Long
Dim Cat2 As Long, Inf2 As Long, Pnf2 As Long, Gpd2 As Long, Exe2 As Long
Dim Dpb As Long, Ppd As Long
Dim Dpb2 As Long, Ppd2 As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
' If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
'If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
Case "DLL"
Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
Case "BIN"
Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
Case "CPA"
Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
Case "VP"
Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Case "BAG"
Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1
Case "XML"
Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1
Case "JS"
Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1
Case "GDL"
Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1
Case "CAB"
Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1
Case "INI"
Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1
Case "CAT"
Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Case "INF"
Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1
Case "PNF"
Let Pnf = Pnf + 1: If rngStr.Font.Color <> 0 Then Let Pnf2 = Pnf2 + 1
Case "GPD"
Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1
Case "EXE"
Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1
' Dim Dpb As Long, Ppd As Long
Case "DPB"
Let Dpb = Dpb + 1: If rngStr.Font.Color <> 0 Then Let Dpb2 = Dpb2 + 1
Case "PPD"
Let Ppd = Ppd + 1: If rngStr.Font.Color <> 0 Then Let Ppd2 = Ppd2 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value ' arrFiles(RwCnt, ClCnt)
Let Els = Els + 1
End Select
Else ' not a file path, or rather not a . in
Dim Fldr As Long: Let Fldr = Fldr + 1
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output
Debug.Print "sys " & Sys & " (" & Sys2 & ")"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp " & Vp & " (" & Vp2 & ")"
Debug.Print "els " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag " & Bag & " (" & Bag2 & ")"
Debug.Print "xml " & Xml & " (" & Xml2 & ")"
Debug.Print "js " & Js & " (" & Js2 & ")"
Debug.Print "gdl " & Gdl & " (" & Gdl2 & ")"
Debug.Print "cab " & Cab & " (" & Cab2 & ")"
Debug.Print "ini " & Ini & " (" & Ini2 & ")"
Debug.Print "cat " & Cat & " (" & Cat2 & ")"
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf " & Inf & " (" & Inf2 & ")"
Debug.Print "pnf " & Pnf & " (" & Pnf2 & ")"
Debug.Print "gpd " & Gpd & " (" & Gpd2 & ")"
Debug.Print "exe " & Exe & " (" & Exe2 & ")"
' Dim Dpb As Long, Ppd As Long
Debug.Print "dpb " & Dpb & " (" & Dpb2 & ")"
Debug.Print "ppd " & Ppd & " (" & Ppd2 & ")"
Debug.Print "Total files is " & Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Dpb + Ppd
Debug.Print "Things with no . are " & Fldr
End Sub
-
In support of this post
http://www.excelfox.com/forum/showth...ge40#post12671
Code:
Option Explicit ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12671
Sub DDAllEarlier_Marz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim WsDDD As Worksheet: Set WsDDD = Worksheets("DDAllComparison")
Dim RngDD1 As Range, RngDD2 As Range '
Set RngDD1 = WsDDD.Range("D4:E680"): Set RngDD2 = WsDDD.Range("F4:H680")
' 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 RngDD1 '----------------------| 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 = RngDD2.Find(what:=Rng.Value, After:=RngDD2.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 = WsDDD.Range("F" & FndRng.Row + 1 & ":H680").Find(what:=Rng.Value, After:=WsDDD.Range("H680"), 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 RngDD1 ---------------|
End Sub
