Appendix Thread. ( Codes for other Threads, ( Avinash ).)

**DocAElstein** · 03-07-2020, 06:52 PM

In support of this Forum post:
http://www.excelfox.com/forum/showth...ll=1#post12575

Before:
_____ Workbook: 1.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Stock Name	Data	Data	Data	Data	Data	Data	Data	Data	Data	Data	Data	Data
2	ACC	800	700	600	500	400	300	200	100	90	80	70
3	ADANIENT	800	700	600	500	400	300	200	100	90	80	70
4	ADANIPORTS	800	700	600	500	400	300	200	100	90	80	70	If there are no highlighted colour cells in the row then copy paste the firt cells of that row i. e 800(B4)
5	ADANIPOWER	800	700	600	500	400	300	200	100	90	80	70	and sorry Doc Sir one mistake happened from my end in providing the info to u , we have to copy and paste the data after highlighted colours cells
6	AMARAJABAT	800	700	600	500	400	300	200	100	90	80	70	And one more thing plz see A8 it doesnt have highlighted colour cells in that row then we have to copy and paste the first cell i. e B8(800)but A8 will not match with column B of 2.xlsx so ignore that don't do anything for that just ignore it
7	AMBUJACEM	800	700	600	500	400	300	200	100	90	80	70
8	ONGC	800	700	600	500	400	300	200	100	90	80	70
9

Worksheet: Sheet1
_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	G	H
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ACC	EQ	130	132.7	127.4	139.1	130.3
3	NSE	AMARAJABAT	EQ	102.35	104.7	101	105.65	103.55
4	NSE	ADANIENT	EQ	215.1	216.65	207.5	221.75	210.35
5	NSE	AMBUJACEM	EQ	198.75	202.4	195.4	204.4	201.05
6	NSE	ADANIPORTS	EQ	339.8	339.8	331.25	349.15	336.35
7	NSE	ADANIPOWER	EQ	268	273.65	253.95	288.5	270.1
8

Worksheet: Sheet1
need match column A stock name of 1.xlsx with column B of 2. xlsx and if it matches then we have to copy and paste the data after highlighted colours cells in that row of 1.xlsx and paste it to column L OF 2.xlsx

If there are no highlighted colour cells in the row then copy paste the firt cells of that row i. e 800(B4)
And one more thing plz see A8 it doesnt have highlighted colour cells in that row then we have to copy and paste the first cell i. e B8(800)but A8 will not match with column B of 2.xlsx so ignore that don't do anything for that just ignore it

here is after
_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	G	H	L
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ACC	EQ	130	132.7	127.4	139.1	130.3	400
3	NSE	AMARAJABAT	EQ	102.35	104.7	101	105.65	103.55	300
4	NSE	ADANIENT	EQ	215.1	216.65	207.5	221.75	210.35	600
5	NSE	AMBUJACEM	EQ	198.75	202.4	195.4	204.4	201.05	800
6	NSE	ADANIPORTS	EQ	339.8	339.8	331.25	349.15	336.35	800
7	NSE	ADANIPOWER	EQ	268	273.65	253.95	288.5	270.1	200
8

Worksheet: Sheet1

_.______________________

here is latest macro, in next post....

**DocAElstein** · 03-07-2020, 06:52 PM

Macro for last post

Code:

Sub PasteHighlightedCellsFromMatchedColumnRows2() ' http://www.excelfox.com/forum/showthread.php/2425-Copy-and-paste-by-highlighted-colour-Paste-Highlighted-Cells-From-Matched-Column-Rows?p=12575&viewfull=1#post12575
Rem 1 Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
 Set Ws1 = Workbooks("1.xlsx").Worksheets.Item("Sheet1"): Set Ws2 = Workbooks("2.xlsx").Worksheets.Item("Sheet1")
Rem 2  .... initial adjustment so that I can detect the highlighted cells in a different way
Dim Rng As Range
'  For Each Rng In Ws1.UsedRange.Offset(0, 2).Resize(, Ws1.UsedRange.Columns.Count - 2) ' We are intersted in the range offset 2 columns to the left of size 2 columns less than the main used range
  For Each Rng In Ws1.Range("A2:L" & Ws1.UsedRange.Rows.Count & "")
    If Rng.Interior.Color = 65535 Then
     Let Rng.Value = "=" & """" & Rng.Value & """"
    Else
    End If
  Next Rng
Rem 3  match column A stock name of 1.xlsx with column B of 2.xlsx and if it matches then copy the yellow highlighted colured cell data in that row of 1.xlsx and paste it to column L OF 2.xlsx
Dim Lr1 As Long: Let Lr1 = Ws1.UsedRange.Rows.Count
  For Each Rng In Ws1.Range("A2:A" & Lr1 & "") '  Ws1 column A
  Dim Lr2 As Long: Let Lr2 = Ws2.UsedRange.Rows.Count
  Dim SrchRng As Range: Set SrchRng = Ws2.Range("B2:B" & Lr2 & "")
  Dim RngMtch As Range
   Set RngMtch = SrchRng.Find(What:=Rng.Value, After:=Ws2.Range("B2"), LookAt:=xlWhole, searchorder:=xlNext, MatchCase:=True) '
    If RngMtch Is Nothing Then
    
    Else ' a cell from column a 1.xlsx is matched to a cell from column B 2.xlsx
    Dim HigChk As Range
     Set HigChk = Rng.Offset(0, 1).Resize(, Ws1.UsedRange.Columns.Count - 1).Find(What:="=", LookIn:=xlFormulas, LookAt:=xlPart)
        If Not HigChk Is Nothing Then ' we found a highlighted cell -----------
        ' copy the yellow highlighted colured cell data in that row of 1.xlsx
         Rng.Offset(0, 1).Resize(, Ws1.UsedRange.Columns.Count - 1).SpecialCells(xlCellTypeFormulas, xlNumbers + xlTextValues).Offset(0, 1).Copy
        ' paste it to column L OF 2.xlsx
        Else ' case no highlighted cell, so column B should be copüied from 1.xlsx
         Rng.Offset(0, 1).Copy
        End If                        ' we were looking for highligted cell ---
     Ws2.Range("L" & RngMtch.Row & "").PasteSpecial Paste:=xlPasteValues
    End If
  Next Rng ' Ws1 column A
Rem 4 save and close both the file after doing the process
Workbooks("1.xlsx").Close savechanges:=False
Workbooks("2.xlsx").Close savechanges:=True
End Sub

1.xlsx : https://app.box.com/s/dgufdfvw3lm3knkvwvp0xgiqpwarqf69
2.xlsx : https://app.box.com/s/51cykk4zd6ldan8puz70o3zyj0e17rwf
macro.xlsm : https://app.box.com/s/tbis0g4n6l6386df6xjwh4cirbtgphzl

**DocAElstein** · 03-09-2020, 01:51 AM

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

**DocAElstein** · 03-09-2020, 02:29 AM

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

**DocAElstein** · 03-10-2020, 02:46 PM

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

**DocAElstein** · 03-12-2020, 12:33 AM

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

**DocAElstein** · 03-12-2020, 10:40 PM

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

**DocAElstein** · 03-13-2020, 10:17 PM

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

**DocAElstein** · 03-18-2020, 03:35 PM

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

**DocAElstein** · 03-19-2020, 05:54 PM

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