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 IfCode: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




Reply With Quote
Bookmarks