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

In support of this post
http://www.excelfox.com/forum/showth...ge19#post12364

Code:

Sub FileTypesHereDoubleDriverFull() 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 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 Dpb As Long Dim Dpb2 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 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 ' 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 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 Case "GPD" Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1 Case "XML" Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1 Case "GDL" Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 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 Case "DPD" Let Dpd = Dpd + 1: If rngStr.Font.Color <> 0 Then Let Dpd2 = Dpd2 + 1 Case "PPD" Let Ppd = Ppd + 1: If rngStr.Font.Color <> 0 Then Let Ppd2 = Ppd2 + 1 Case "CAB" Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1 Case "BAG" Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1 Case "EXE" Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1 ' DPB Case "DPB" Let Dpb = Dpb + 1: If rngStr.Font.Color <> 0 Then Let Dpb2 = Dpb2 + 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 & ")" Debug.Print "dll " & Ddl & " (" & Ddl2 & ")" Debug.Print "bin " & Bin & " (" & Bin2 & ")" Debug.Print "cpa " & Cpa & " (" & Cpa2 & ")" Debug.Print "vp " & Vp & " (" & Vp2 & ")" 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 & ")" Debug.Print "ini " & Ini & " (" & Ini2 & ")" Debug.Print "cat " & Cat & " (" & Cat2 & ")" Debug.Print "gpd " & Gpd & " (" & Gpd2 & ")" Debug.Print "xml " & Xml & " (" & Xml2 & ")" Debug.Print "gdl " & Gdl & " (" & Gdl2 & ")" ' Js As Long, Dpd As Long, Ppd As Long, Cab As Long, Bag As Long, Exe As Long Debug.Print "js " & Js & " (" & Js2 & ")" Debug.Print "dpd " & Dpd & " (" & Dpd2 & ")" Debug.Print "cab " & Cab & " (" & Cab2 & ")" Debug.Print "bag " & Bag & " (" & Bag2 & ")" Debug.Print "ppd " & Ppd & " (" & Ppd2 & ")" Debug.Print "exe " & Exe & " (" & Exe2 & ")" ' DPB Debug.Print "dpb " & Dpb & " (" & Dpb2 & ")" 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 & ")" End Sub

In support of this Post
http://www.excelfox.com/forum/showth...ge19#post12364

Code:

Sub Compare_drivers_In_DoubleDriver() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page19#post12364 Rem 0 If ActiveSheet.Name <> "drivers" Then ' This macro was intended to be run from drivers to look for things from it in DoubleDriver MsgBox prompt:="Oops": Exit Sub ' **the selection should be in drivers Else End If Rem 1 Worksheets info Dim WsDD As Worksheet, WsDrs As Worksheet Set WsDD = Worksheets("DDAllBefore"): Set WsDrs = Worksheets("drivers") 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, **the selection should be in drivers Dim CelVl As String: Let CelVl = SrchForCel.Value If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' 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 = Replace(CelVl, ".mui", "", 1, 1, vbBinaryCompare) ' 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("=DDAllBefore!D5:DDAllBefore!G670") ' Dim FndCel As Range: Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DDAllBefore!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 WsDrs.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 WsDD.Activate: FndCel.Select ' the other workseet, that being looked in for the file 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 Else ' case no file path string in cell End If Next SrchForCel End Sub

ExplorerBefore Double Driver V DriverStore Abort.xlsm : https://app.box.com/s/uqupktt1ppxar3frhg2n7tqbb9vn181e

In support of this post
http://www.excelfox.com/forum/showth...ge21#post12386

Code:

Sub CompareDriverFilesDoubleDriverInDriverStoreFindNext() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page21#post12386 Rem 0 If ActiveSheet.Name <> "DDAllBefore" Then MsgBox prompt:="Oops": Exit Sub Else End If Rem 1 Worksheets info Dim WsDD As Worksheet, WsDrSt As Worksheet Set WsDD = Worksheets("DDAllBefore"): 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 If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file 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 Let FileNmeSrchFor = CelVl ' In Double Drivers the cells are not shown as a full path, so the last line is not necerssary 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 Do While Not FndCel Is Nothing ' Start Find next loop = 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 WsDD.Activate: SrchForCel.Select Let SrchForCel.Font.Underline = True Else End If '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 WsDD.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 End If Else ' case no file path string in cell End If Next SrchForCel End Sub

Do While Loop start further down macro in support of this Post:

Code:

Sub CompareDriverFilesDoubleDriverInDriverStoreFindNext() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page21#post12386 Rem 0 If ActiveSheet.Name <> "DDAllBefore" Then MsgBox prompt:="Oops": Exit Sub Else End If Rem 1 Worksheets info Dim WsDD As Worksheet, WsDrSt As Worksheet Set WsDD = Worksheets("DDAllBefore"): 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 If CelVl <> "" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file 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 Let FileNmeSrchFor = CelVl ' In Double Drivers the cells are not shown as a full path, so the last line is not necerssary 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 'Do While Not FndCel Is Nothing ' Start Find next loop = 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 WsDD.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 WsDD.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 End If Else ' case no file path string in cell End If Next SrchForCel End Sub

2 Attachment(s)

In support of answer for this Thread:
http://www.excelfox.com/forum/showth...lighted-colour

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

_Row\^Col
A

B

C

D

E

F

G

1

Stock Name

2

A2

22

32

42

52

62

72

3

A3

23

33

43

53

63

73

4

A4

24

34

44

54

64

74

5

A5

25

35

45

55

65

75

6

A6

26

36

46

56

66

76

7

A7

27

37

47

57

67

77

8

A8

28

38

48

58

68

78

Worksheet: Tabelle1

After the following code section we have a modified worksheet

Code:

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 - 1) If Rng.Interior.Color = 65535 Then Let Rng.Value = "=" & """" & Rng.Value & """" Else End If

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

_Row\^Col
A

B

C

D

E

F

G

H

1

Stock Name

2

A2

22

32

42

52

62

72

3

A3

23

="33"

43

53

63

73

4

A4

24

34

44

="54"

64

="74"

5

A5

25

35

="45"

55

65

75

6

A6

26

36

46

56

66

76

7

A7

27

37

47

57

="67"

77

8

A8

28

38

48

58

68

78

9

Worksheet: Tabelle1

First worksheet in 2.xlsx, before running macro, showing the Matched A5 in row 6
_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

H

I

J

K

L

M

1
Symbol

2
x H2

3
r H3

4
f H4

5
gdg H5

6
A5 H6

7

5
H7

8
h H8

9

Worksheet: Tabelle1

After running macro:-
_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

H

I

J

K

L

1
Symbol

2
x H2

3
r H3

4
f H4

5
gdg H5

6
A5 H6 45

7

5
H7

8
h H8

9

Worksheet: Tabelle1

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

_Row\^Col	A	B	C	D	E	F	G
1	Stock Name
2	A2	22	32	42	52	62	72
3	A3	23	33	43	53	63	73
4	A4	24	34	44	54	64	74
5	A5	25	35	45	55	65	75
6	A6	26	36	46	56	66	76
7	A7	27	37	47	57	67	77
8	A8	28	38	48	58	68	78

_Row\^Col	A	B	C	D	E	F	G
1	Stock Name
2	A2	22	32	42	52	62	72
3	A3	23	="33"	43	53	63	73
4	A4	24	34	44	="54"	64	="74"
5	A5	25	35	="45"	55	65	75
6	A6	26	36	46	56	66	76
7	A7	27	37	47	57	="67"	77
8	A8	28	38	48	58	68	78
9

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

I

J

K

L

M

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

I

J

K

L

M

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....

_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

_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

_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

2 Attachment(s)

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

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

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

Code:

' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12672 ' 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 Private Sub FileTypesHereIndrivers_() Rem 1 Worksheets info Dim Ws As Worksheet: Set Ws = Worksheets("drivers marz 2020") Dim Rng As Range: Set Rng = Ws.Range("C2:E180") ' Ws.Range("F2:H180") ' Ws.Range("C2:E180") '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 Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long Dim Bag2 As Long, Xml2 As Long, Js2 As Long, Gdl2 As Long, Cab2 As Long, Ini2 As Long Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long Dim Cat2 As Long, Inf2 As Long, Pnf2 As Long, Gpd2 As Long, Exe2 As Long Dim Sam As Long Dim Sam2 As Long Rem 3 Looping 'Dim ClCnt As Long, RwCnt As Long ' For RwCnt = 1 To UBound(arrFiles(), 1) ' For ClCnt = 1 To UBound(arrFiles(), 2) Dim rngStr As Range For Each rngStr In Rng '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 ' Dim Xtn As String: Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1)) ' this will give the text starting from after the first dot . If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path Dim Xtn As String: Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1)) ' this will give the text starting from after the first dot . ' this next section catches single . things ' If Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 1 Then ' case a single . If Len(rngStr.Value) - Len(Replace(rngStr.Value, ".", "")) = 1 Then ' case a single . 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 = Bag + 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 ' sam Case "SAM" Let Sam = Sam + 1: If rngStr.Font.Color <> 0 Then Let Sam2 = Sam2 + 1 Case Else Debug.Print "Case Else for single "" . "" " & rngStr.Value Let Els = Els + 1 End Select ElseIf Len(rngStr.Value) - Len(Replace(rngStr.Value, ".", "")) = 2 Then ' a thing like hidscanner.dll.mui or sdstor.sys.mui ' this next section catches double . . things Dim DllMui As Long, SysMui As Long, Els2 As Long Dim DllMui2 As Long, SysMui2 As Long Select Case UCase(Xtn) Case "DLL.MUI" Let DllMui = DllMui + 1: If rngStr.Font.Color <> 0 Then Let DllMui2 = DllMui + 1 Case "SYS.MUI" Let SysMui = SysMui + 1: If rngStr.Font.Color <> 0 Then Let SysMui2 = SysMui + 1 Case Else Debug.Print "Case Else for double "" . . "" " & rngStr.Value Let Els2 = Els2 + 1 End Select ElseIf Len(rngStr.Value) - Len(Replace(rngStr.Value, ".", "")) > 2 Then ' this section catches strings with dots more than 2 Dim LtsDts As Long Debug.Print "More than 2 dots -- " & rngStr.Value Let LtsDts = LtsDts + 1 End If Else ' not a file, ( well no . in it anyway ) Dim Fldr As Long Debug.Print "Folder? " & rngStr.Value Let Fldr = Fldr + 1 End If End If Next rngStr ' Next ClCnt ' Next RwCnt 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 "Else1 " & 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 & ")" ' sam Debug.Print "sam " & Sam & " (" & Sam2 & ")" ' Dim DllMui As Long, SysMui As Long, Els2 As Long Debug.Print "dll.mui " & DllMui & " (" & DllMui2 & ")" Debug.Print "sys.mui " & SysMui & " (" & SysMui2 & ")" Debug.Print "Else2 " & Els2 Debug.Print "Total files is " & Els + Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Els2 + DllMui + SysMui + Sam & " (" & Sys2 + Ddl2 + Bin2 + Cpa2 + Vp2 + Bag2 + Xml2 + Js2 + Gdl2 + Cab2 + Ini2 + Cat2 + Inf2 + Pnf2 + Gpd2 + Exe2 + DllMui2 + SysMui2 + Sam2 & ")" Debug.Print "Total Folders is " & Fldr Debug.Print "Total things with more than 2 dots is " & LtsDts End Sub

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

Code:

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

In support of this post…

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

Code:

' =ANZAHL2(H3:J4396) =ANZAHL2(D3:F4396) G3:J4396 C3:F4396 Private Sub FileTypesHereArraysNew() Rem 1 Worksheets info Dim Ws As Worksheet: Set Ws = Me Dim Rng As Range: Set Rng = Ws.Range("A1:F4397") 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 Sam As Long Dim Inf_loc As Long, Hlp As Long, Ntf As Long, Ppd As Long, Tbl As Long, Icc As Long, Dat As Long Dim Dpb As Long, Cty As Long, Msc As Long, Xst As Long Rem 3 Looping Dim ClCnt As Long, RwCnt As Long For RwCnt = 1 To UBound(arrFiles(), 1) For ClCnt = 1 To UBound(arrFiles(), 2) If ClCnt = 2 And arrFiles(RwCnt, ClCnt) <> "" Then ' case of folder path Dim Fldr As Long ' Debug.Print "Folder? " & arrFiles(RwCnt, ClCnt) Let Fldr = Fldr + 1 Let RwCnt = RwCnt + 1 ' this is naughty, but will stop us hitting the folder name as the columns increase Else ' not a folder and if empty then not in column 2 If arrFiles(RwCnt, ClCnt) = "" 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 Dim Xtn As String: Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1)) ' this will give the text starting from after the first dot . ' this next section catches single . things If Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 1 Then ' case a single . Select Case UCase(Xtn) Case "SYS" Let Sys = Sys + 1 Case "DLL" Let Ddl = Ddl + 1 Case "BIN" Let Bin = Bin + 1 Case "CPA" Let Cpa = Cpa + 1 Case "VP" Let Vp = Vp + 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 Case "XML" Let Xml = Xml + 1 Case "JS" Let Js = Js + 1 Case "GDL" Let Gdl = Gdl + 1 Case "CAB" Let Cab = Cab + 1 Case "INI" Let Ini = Ini + 1 Case "CAT" Let Cat = Cat + 1 ' Inf As Long, Pnf As Long, Gpd As Long, Exe as long Case "INF" Let Inf = Inf + 1 Case "PNF" Let Pnf = Pnf + 1 Case "GPD" Let Gpd = Gpd + 1 Case "EXE" Let Exe = Exe + 1 ' sam Case "SAM" Let Sam = Sam + 1 'inf_loc Pnf HLP NTF Ppd TBL ICC DAT Case "INF_LOC" Let Inf_loc = Inf_loc + 1 Case "HLP" Let Hlp = Hlp + 1 Case "NTF" Let Ntf = Ntf + 1 Case "PPD" Let Ppd = Ppd + 1 Case "TBL" Let Tbl = Tbl + 1 Case "ICC" Let Icc = Icc + 1 Case "DAT" Let Dat = Dat + 1 'Dim Dpb As Long, Cty As Long, Msc As Long, Xst As Long Case "DPB" Let Dpb = Dpb + 1 Case "CTY" Let Cty = Cty + 1 Case "MSC" Let Msc = Msc + 1 Case "XST" Let Xst = Xst + 1 Case Else Debug.Print "Case Else for single "" . "" " & arrFiles(RwCnt, ClCnt) Let Els = Els + 1 End Select ElseIf Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) = 2 Then ' a thing like hidscanner.dll.mui or sdstor.sys.mui ' this next section catches double . . things Dim DllMui As Long, SysMui As Long, Els2 As Long Select Case UCase(Xtn) Case "DLL.MUI" Let DllMui = DllMui + 1 Case "SYS.MUI" Let SysMui = SysMui + 1 Case Else Debug.Print "Case Else for double "" . . "" " & arrFiles(RwCnt, ClCnt) Let Els2 = Els2 + 1 End Select ElseIf Len(arrFiles(RwCnt, ClCnt)) - Len(Replace(arrFiles(RwCnt, ClCnt), ".", "")) > 2 Then ' this section catches strings with dots more than 2 Dim LtsDts As Long Debug.Print "More than 2 dots -- " & arrFiles(RwCnt, ClCnt) Let LtsDts = LtsDts + 1 End If Else ' not a file, ( well no . in it anyway ) ' Dim Fldr As Long ' Debug.Print "Folder? " & arrFiles(RwCnt, ClCnt) ' Let Fldr = Fldr + 1 End If End If ' end of case empty cell End If ' end of folder is counted based on "G:\" in column B Next ClCnt Next RwCnt Rem 4 output Debug.Print "sys " & Sys Debug.Print "dll " & Ddl Debug.Print "bin " & Bin Debug.Print "cpa " & Cpa Debug.Print "vp " & Vp Debug.Print "Else1 " & 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 Debug.Print "xml " & Xml Debug.Print "js " & Js Debug.Print "gdl " & Gdl Debug.Print "cab " & Cab Debug.Print "ini " & Ini Debug.Print "cat " & Cat ' Inf As Long, Pnf As Long, Gpd As Long, Exe as long Debug.Print "inf " & Inf Debug.Print "pnf " & Pnf Debug.Print "gpd " & Gpd Debug.Print "exe " & Exe ' sam Debug.Print "sam " & Sam ' inf_loc Pnf HLP NTF Ppd TBL ICC DAT Debug.Print "inf_loc " & Inf_loc Debug.Print "pnf " & Pnf Debug.Print "hlp " & Hlp Debug.Print "ntf " & Ntf Debug.Print "ppd " & Ppd Debug.Print "tbl " & Tbl Debug.Print "icc " & Tbl Debug.Print "dat " & Dat ' Dim Dpb As Long, Cty As Long, Msc As Long, Xst As Long Debug.Print "dpb " & Dpb Debug.Print "cty " & Cty Debug.Print "msc " & Msc Debug.Print "xst " & Xst ' Dim DllMui As Long, SysMui As Long, Els2 As Long Debug.Print "dll.mui " & DllMui Debug.Print "sys.mui " & SysMui Debug.Print "Else2 " & Els2 Debug.Print "Total files is " & Els + Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Els2 + DllMui + SysMui + Sam + Inf_loc + Hlp + Ntf + Ppd + Tbl + Icc + Dat + Dpb + Cty + Msc + Xst Debug.Print "Total Folders is " & Fldr Debug.Print "Total things with more than 2 dots is " & LtsDts 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

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 .

Code:

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

Code:

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

In support of this post
http://www.excelfox.com/forum/showth...ge41#post12675
First use of Dictionary alternative.
The following two macros give similar results. The first is the big Case Else macro and the second the first use of a Dictionary, Dik, alternative.

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 Private Sub FilesTypeHereFromFunction() Rem 1 Worksheets info Dim Ws As Worksheet: Set Ws = Me Dim rng2BSrchd As Range: Set rng2BSrchd = Ws.Range("D4:E260") Rem 2 A Dik for the extensions and count thereof '2a) Make the Dik Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary") Dik.CompareMode = vbTextCompare ' make case insensitive, probably not necersary in our case as we do all comares at UCase to make it already case insensitive '2b) Fill the Dik Dim rngStr As Range For Each rngStr In rng2BSrchd If rngStr.Value = "" Then ' empty cell Do nothing Else Dim FkBk As String Let FkBk = GetMeExtension(Trim(rngStr.Value)) If Left(FkBk, 1) = "0" Then Dim Fldrs As String Let Fldrs = Fldrs & rngStr.Value & vbCr & vbLf Else ' we have an extension of a type we may or may not have had already If Dik.Exists("" & FkBk & "") Then Let Dik.Item("" & FkBk & "") = Dik.Item("" & FkBk & "") + 1 ' add to count of this extension, - the count is actually held as the item Else Dik.Add Key:="" & FkBk & "", Item:=1 ' I create an item who's key is the extension string, and make item the count of it, 1 here initially End If End If End If Next rngStr '2c) output from Dik Dim Kys() As Variant, Itms() As Variant Let Kys() = Dik.Keys(): Let Itms() = Dik.Items() Dim Cnt As Long For Cnt = 0 To Dik.Count - 1 ' Note Dictionaries by default start at 0, but the count is the actual number, so Count-1 is the last indicee and 0 is the first Debug.Print Kys()(Cnt) & " " & Itms()(Cnt) Next Cnt End Sub

In support of this post
http://www.excelfox.com/forum/showth...ge41#post12675

Code:

' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12675 Sub NewCmdVNewDD() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646 Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz") Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection Set Rngcmd = Wscmd.Range("D4:E260") If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub Dim WsDD As Worksheet: Set WsDD = Worksheets("DDAllComparison") Dim RngDD As Range Set RngDD = WsDD.Range("E4:E680") Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3 ' take each cell in cmd range and find it in DD range Dim Rng As Range For Each Rng In Selection If Rng <> "" Then Dim FndRng As Range ' range file cell found in DD Set FndRng = RngDD.Find(what:=Rng.Value, After:=RngDD.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) ' If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using Wscmd.Activate: Rng.Select Let Rng.Font.ColorIndex = ClrIdx Application.Wait (Now + TimeValue("00:00:01")) Do While Not FndRng Is Nothing WsDD.Activate: FndRng.Select Let FndRng.Font.ColorIndex = ClrIdx Application.Wait (Now + TimeValue("00:00:01")) Set FndRng = WsDD.Range("E" & FndRng.Row + 1 & ":E680").Find(what:=Rng.Value, After:=WsDD.Range("E680"), 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 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

2 Attachment(s)

Macro for this post solution, ( written by the son of God )
http://www.excelfox.com/forum/showth...ll=1#post12897

Code:

Sub conditionally_delete3() ' http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12893&viewfull=1#post12893 Rem 1 Worksheets info Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet Set Wb1 = Workbooks("STEP1U.xlsb") ' Workbooks("sample1.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Upstox\STEP1U.xlsb") Set Ws1 = Wb1.Worksheets.Item(1) ' worksheet of first tab Set Wb2 = Workbooks("1.xls") ' Workbooks("sample2.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") Set Ws2 = Wb2.Worksheets.Item(1) ' worksheet of first tab '1b Ranges Dim Rng1A As Range, Rng2B As Range Set Rng1A = Ws1.Range("A2:A" & Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row & "") Set Rng2B = Ws2.Range("B2:B" & Ws2.Range("B" & Ws2.Rows.Count & "").End(xlUp).Row & "") Rem 2 Delete an entire row in Ws2 if value in column B is not anywhere in column A of Ws1 Dim Rws As Long For Rws = Ws2.Range("B" & Ws2.Rows.Count & "").End(xlUp).Row To 2 Step -1 Dim rngFnd As Range Set rngFnd = Rng1A.Find(what:=Ws2.Range("B" & Rws & "").Value, After:=Rng1A.Item(1), 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 If rngFnd Is Nothing Then ' The value from column B in Ws2 was not found in column A of Ws1 Ws2.Range("B" & Rws & "").EntireRow.Delete Shift:=xlUp Else ' The value from column B in Ws2 was found in column A of Ws1 so do nothing End If Next Rws ' Wb1.Save ' Wb1.Close ' Wb2.Save ' Wb2.Close End Sub

1.xls: https://app.box.com/s/th2xzmkh7rnfr4qf4dho1kpgudndm073

In support of these posts

http://www.excelfox.com/forum/showth...ge41#post12676
http://www.excelfox.com/forum/showth...ge41#post12677
http://www.excelfox.com/forum/showth...ge41#post12678

Code:

' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12676 Sub NewCmdVNewDD() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646 Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz") Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection Set Rngcmd = Wscmd.Range("D4:E260") If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub Dim WsDD As Worksheet: Set WsDD = Worksheets("DDAllComparison") Dim RngDD As Range Set RngDD = WsDD.Range("E4:E680") Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3 ' take each cell in cmd range and find it in DD range Dim Rng As Range For Each Rng In Selection If Rng <> "" Then Dim FndRng As Range ' range file cell found in DD Set FndRng = RngDD.Find(what:=Rng.Value, After:=RngDD.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) ' If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using Wscmd.Activate: Rng.Select Let Rng.Font.ColorIndex = ClrIdx Application.Wait (Now + TimeValue("00:00:01")) Do While Not FndRng Is Nothing WsDD.Activate: FndRng.Select Let FndRng.Font.ColorIndex = ClrIdx Application.Wait (Now + TimeValue("00:00:01")) Set FndRng = WsDD.Range("E" & FndRng.Row + 1 & ":E680").Find(what:=Rng.Value, After:=WsDD.Range("E680"), 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 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 ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12677 Sub NewCmdVNewdrivers() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646 Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz") Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection Set Rngcmd = Wscmd.Range("E4:F260") If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub Dim Wsdrs As Worksheet: Set Wsdrs = Worksheets("drivers marz 2020") Dim Rngdrs As Range Set Rngdrs = Wsdrs.Range("D6:E180") Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3 ' take each cell in cmd range and find it in DD range Dim Rng As Range For Each Rng In Selection If Rng <> "" Then Dim FndRng As Range ' range file cell found in DD Set FndRng = Rngdrs.Find(what:=Rng.Value, After:=Rngdrs.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) ' If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using Wscmd.Activate: Rng.Select Let Rng.Font.ColorIndex = ClrIdx Application.Wait (Now + TimeValue("00:00:01")) Do While Not FndRng Is Nothing Wsdrs.Activate: FndRng.Select Let FndRng.Font.ColorIndex = ClrIdx Application.Wait (Now + TimeValue("00:00:01")) Set FndRng = Wsdrs.Range("D" & FndRng.Row + 1 & ":E180").Find(what:=Rng.Value, After:=Wsdrs.Range("E180"), 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 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 ---- ---------------| End Sub ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12678 Sub NewCmdVNewDriverStore() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646 Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz") Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection Set Rngcmd = Wscmd.Range("E4:F260") If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub Dim WsDS As Worksheet: Set WsDS = Worksheets("DriverStoreCompareMarz17 2020") Dim RngDS As Range Set RngDS = WsDS.Range("D6:F4395") Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3 ' take each cell in cmd range and find it in DD range Dim Rng As Range For Each Rng In Selection If Rng <> "" Then Dim FndRng As Range ' range file cell found in DD Set FndRng = RngDS.Find(what:=Rng.Value, After:=RngDS.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) ' If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using Wscmd.Activate: Rng.Select Let Rng.Font.ColorIndex = ClrIdx Application.Wait (Now + TimeValue("00:00:01")) Do While Not FndRng Is Nothing WsDS.Activate: FndRng.Select Let FndRng.Font.ColorIndex = ClrIdx Application.Wait (Now + TimeValue("00:00:01")) Set FndRng = WsDS.Range("D" & FndRng.Row + 1 & ":F4395").Find(what:=Rng.Value, After:=WsDS.Range("F4395"), 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 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

1 Attachment(s)

http://www.excelfox.com/forum/showth...ll=1#post12897
Test blog

Loop backwards when deleting rows

Important notes in support of these posts: http://www.excelfox.com/forum/showth...ll=1#post12897
https://excelfox.com/forum/showthrea...ire-row-by-vbA
https://excelfox.com/forum/showthrea...wo-excel-files

When deleting rows, ( and when deleting things generally ) , in a Loop, we will usually need to loop backwards.
If we loop backwards, things “behind us” were already considered, and so no strange effects will be noticed if they are effected by further deletions:
If we Loop forwards , rows will shift up after a delete, and so when moving on a row we may miss a row that is needed to be deleted, or other strange effects may occur:
Due to the deletion, things “ahead of us” , which we have not yet considered, may change in some way. The row number or item number, etc., of something not yet considered may change: This can cause VBA to get confused. We may get the wrong results, or worse, cause some coding error:
At the start of a loop, the parameters such as start, stop, and increment are set. Changing these after the loop begins may cause problems. It is generally bad practice to change loop parameters after the loop begins and before the loop ends, especially if those parameters are to be further used before the loop ends.

For example, in the case of deleting things in a looping process, this may sometimes give us problems:

__For Cnt = 1 To 4 Step 1 ' __ 1 2 3 4

Usually, this alternative, would overcome problems:

__For Cnt = 4 To 1 Step -1 ' __ 4 3 2 1

Example

We want to delete rows based on value in column C, in the range A1:C4: If the value is Delete this row , then the entire row should be deleted

Before:-

_____ Workbook: Delete Rows.xls ( Using Excel 2007 32 bit )

_Row\^Col A B C D E F G

1 11 a Do not delete

2 12 B Delete this row

3 13 c Delete this row

4 14 D Do not delete

5

6 Original Range:-

7 11 a Do not delete

8 12 B Delete this row

9 13 c Delete this row

10 14 D Do not delete

11

Worksheet: MySheet

So in the above example, we want to delete rows 2 and 3.

We could try this macro, but it gives the wrong results. At first glance we would expect it to work.
It loops through the rows, and deletes the row if the value in column C is Delete this row. One could be forgiven for thinking that it should work.

Code:

Option Explicit Sub LoopForwardsToDeleteRows() Rem 1 Worksheets info Dim Wb As Workbook, Ws As Worksheet Set Wb = ThisWorkbook: Set Ws = Wb.Worksheets.Item(1) Rem 2 Loop to delete rows Dim Rws As Long For Rws = 1 To 4 ' 1 2 3 4 If Ws.Range("C" & Rws & "").Value = "Delete this row" Then Ws.Range("C" & Rws & "").EntireRow.Delete Shift:=xlUp ' Delete entire row, and Shift all rows above up to fill space Else ' Do nothing End If Next Rws End Sub

After running the above macro we have

_____ Workbook: Delete Rows.xls ( Using Excel 2007 32 bit )

_Row\^Col A B C D E F G

1 11 a Do not delete

2 13 c Delete this row

3 14 D Do not delete

4

5 Original Range:-

6 11 a Do not delete

7 12 B Delete this row

8 13 c Delete this row

9 14 D Do not delete

10

11

Worksheet: MySheet

This is what goes on:
Nothing is done to the first row. No problems
The second row is deleted as expected, because cell C2 value was Delete this row
After the second row is deleted, the rows which were after the second row, are all shifted one row up so as to fill the space or “hole” left by the removed row. ( We cannot have a “black hole” in an Excel worksheet:. Excel does not allow this. – The spreadsheet cells are moved so as to “fill” the hole made by the deletion. “New” cells are added as necessary at the worksheet perimeter – In this case a new virgin row is added at the bottom of the worksheet )
The result of the second row being deleted, and the necessary shifting of cells to fill the “hole” which is done, is as follows:
Our original 4th row now becomes the 3rd row. That does not cause any problems.
Our original 3rd row now becomes the 2nd row. This is the problem. The second row has already been considered. It will not be considered again. The original 3rd row, ( now, as a result of the first deletion and cell shifting, the second row ) will not be considered. So it remains. It is not considered. It will therefore not be deleted.
When looping forward and deleting, rows not yet considered will be moved: This may cause problems.

The solution to the problem is to loop backwards. When looping backwards, if a row is deleted, then all rows “behind”/ “above” are shifted down. All those rows have already been considered, and either left as they are or deleted.
The next row to be considered, when looping backwards in a worksheet, will always be the next, not yet considered, row, regardless of whether the last row considered was deleted or not: None of the rows not yet considered have been shifted.
When looping backwards and deleting, rows not yet considered will not have been moved

So we try again

Before, ( as in previous example )

_____ Workbook: Delete Rows.xls ( Using Excel 2007 32 bit )

_Row\^Col A B C D E F G

1 11 a Do not delete

2 12 B Delete this row

3 13 c Delete this row

4 14 D Do not delete

5

6 Original Range:-

7 11 a Do not delete

8 12 B Delete this row

9 13 c Delete this row

10 14 D Do not delete

11

Worksheet: MySheet

Macro: ( looping backwards )

Code:

Sub LoopBackwardsToDeleteRows() Rem 1 Worksheets info Dim Wb As Workbook, Ws As Worksheet Set Wb = ThisWorkbook: Set Ws = Wb.Worksheets.Item(1) Rem 2 Loop to delete rows Dim Rws As Long For Rws = 4 To 1 Step -1 ' 4 3 2 1 If Ws.Range("C" & Rws & "").Value = "Delete this row" Then Ws.Range("C" & Rws & "").EntireRow.Delete Shift:=xlUp ' Delete entire row, and Shift all rows above up to fill space Else ' Do nothing End If Next Rws End Sub

After:

_____ Workbook: Delete Rows.xls ( Using Excel 2007 32 bit )

_Row\^Col A B C D E F G

1 11 a Do not delete

2 14 D Do not delete

3

4 Original Range:-

5 11 a Do not delete

6 12 B Delete this row

7 13 c Delete this row

8 14 D Do not delete

9

10

11

Worksheet: MySheet

This time we have the correct results: Looping backwards gives correct results. Looping fowards may give incorrect results.

In support of this Thread
http://www.excelfox.com/forum/showth...the-entire-row

Before

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

_Row\^Col
A

B

C

D

E

F

G

H

I

1
Exchange Symbol Series/Expiry Open High Low Prev Close LTP

2
NSE ACC EQ
1014

1030

955.5

998.45

957.4

3
NSE ADANIPORTS EQ
27.35

27.75

25.65

25.65

25.85

4

Worksheet: Tabelle1

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

_Row\^Col
A

B

C

D

E

F

G

H

I

1
Exchange Symbol Series/Expiry Open High Low Prev Close LTP

2
NSE ACC EQ
1014

1030

955.5

998.45

957.4

3
NSE ADANIPORTS EQ
27.35

28

29

30

27.35

4

Worksheet: Tabelle2

If column H of sample2.xlsx matches with Column D then look column B data of sample2.xlsx and find that data in sample1.xlsx in column B and after getting that data in sample1.xlsx in column B , copy that entire row of sample1.xlsx and paste that in sample2.xlsx in the same row

Result:

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

Exchange Symbol Series/Expiry Open High Low Prev Close LTP

NSE ACC EQ
1014

1030

955.5

998.45

957.4

NSE ADANIPORTS EQ
27.35

27.75

25.65

25.65

25.85

Worksheet: Tabelle2

_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	1014	1030	955.5	998.45	957.4
3	NSE	ADANIPORTS	EQ	27.35	27.75	25.65	25.65	25.85
4

_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	1014	1030	955.5	998.45	957.4
3	NSE	ADANIPORTS	EQ	27.35	28	29	30	27.35
4

In support of this Post:
http://www.excelfox.com/forum/showth...ll=1#post13014

Before:

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

_Row\^Col
A

B

C

D

E

F

G

H

I

1
Exchange Symbol Series/Expiry Open High Low Prev Close LTP

2
NSE ACC EQ
1000

1030

955.5

998.45

957.4

3
NSE ADANIENT EQ
27.35

27.75

25.65

25.65

25.85

4
NSE ADANIPORTS EQ
259

259.6

244

248.2

251.3

5
NSE ADANIPOWER EQ 5, 4 5, 5 5, 6 5, 7 5, 8

6
NSE AMARAJABAT EQ
459.8

482.25

445.1

439.35

455.35

7
NSE AMBUJACEM EQ 7, 4 7, 5 7, 6 7, 7 7, 8

8
NSE APOLLOHOSP EQ 8, 4 8, 5 8, 6 8, 7 8, 8

9

Worksheet: anything

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

_Row\^Col
A

1
SYMBOL

2
ACC

3
ADANIPORTS

4
AMARAJABAT

5

Worksheet: anything

run macro:

Code:

' http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste/page2#post13014 http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste?p=13014&viewfull=1#post13014 ' http://www.excelfox.com/forum/showthread.php/2445-copy-and-paste-by-vba http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste?p=13014&viewfull=1#post13014 Sub STEP6d() ' match column B of sample1.xlsx matches with column A of sample2.xlsx ' if it matches then copy paste the data from column D to column H to sample2.xlsx from column B Dim Wb1 As Workbook, Wb2 As Workbook ' If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ") Set Wb1 = Workbooks("sample1.xlsx") ' Set Wb1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' w1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") ' change the file path If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ") Set Wb2 = Workbooks("sample2.xlsx") ' Set Wb2 = Workbooks.Open(ThisWorkbook.Path & "\FundsCheck.xlsb") ' w2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\FundsCheck.xlsb") ' change the file path If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ") Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Wb1.Worksheets("anything") ' sheet name can be anything 'Set Ws1 = Wb1.Worksheets.Item(1) Set Ws2 = Wb2.Worksheets("anything") 'Set Ws2 = Wb2.Worksheets.Item(1) Dim Lr1 As Long, Lr2 As Long ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. ) Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count).End(xlUp).Row Let Lr2 = Ws2.Range("A" & Ws2.Rows.Count).End(xlUp).Row Dim Cnt As Long For Cnt = 2 To Lr2 Dim FndCel As Range ' http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-or-replace-entire-row?p=13007&viewfull=1#post13007 Dim rngSrch As Range ' Set rngSrch = Ws1.Range("B2:B" & Lr1 & "") Set FndCel = rngSrch.Find(What:=Ws2.Range("A" & Cnt & "").Value, After:=Ws1.Range("B2"), 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 ' The range to be copied is always offset by 0 rows and +2 column from the cell found, FndCel, in column B of sample1.xlsx . Its size will be 1 row and 5 columns FndCel.Offset(0, 2).Resize(1, 5).Copy ' copy column D to column H ' paste the data from column D to column H to sample2.xlsx from column B Ws2.Range("A" & Cnt & "").Offset(0, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Next Cnt End Sub

After Result:-

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

_Row\^Col
A

B

C

D

E

F

G

1
SYMBOL

2
ACC
1000

1030

955.5

998.45

957.4

3
ADANIPORTS
259

259.6

244

248.2

251.3

4
AMARAJABAT
459.8

482.25

445.1

439.35

455.35

5

Worksheet: anything

_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	1000	1030	955.5	998.45	957.4
3	NSE	ADANIENT	EQ	27.35	27.75	25.65	25.65	25.85
4	NSE	ADANIPORTS	EQ	259	259.6	244	248.2	251.3
5	NSE	ADANIPOWER	EQ	5, 4	5, 5	5, 6	5, 7	5, 8
6	NSE	AMARAJABAT	EQ	459.8	482.25	445.1	439.35	455.35
7	NSE	AMBUJACEM	EQ	7, 4	7, 5	7, 6	7, 7	7, 8
8	NSE	APOLLOHOSP	EQ	8, 4	8, 5	8, 6	8, 7	8, 8
9

_Row\^Col	A
1	SYMBOL
2	ACC
3	ADANIPORTS
4	AMARAJABAT
5

_Row\^Col	A	B	C	D	E	F
1	SYMBOL
2	ACC	1000	1030	955.5	998.45	957.4
3	ADANIPORTS	259	259.6	244	248.2	251.3
4	AMARAJABAT	459.8	482.25	445.1	439.35	455.35
5

Macro for this Post
' http://www.excelfox.com/forum/showth...ll=1#post13058 http://www.excelfox.com/forum/showth...3058#post13058

Code:

' http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste-by-VBA-based-on-criteria?p=13058&viewfull=1#post13058 http://www.excelfox.com/forum/showthread.php/2454-copy-and-paste-by-vba?p=13058#post13058 Sub Step10() Rem 1 Worksheets info Dim Wb1 As Workbook, Wb2 As Workbook ' If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ") Set Wb1 = Workbooks("1.xlsx") ' Workbooks("sample1.xlsx") ' Set Wb1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' w1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") ' change the file path If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ") Set Wb2 = Workbooks("2.xlsx") ' Workbooks("sample2.xlsx") ' Set Wb2 = Workbooks.Open(ThisWorkbook.Path & "\FundsCheck.xlsb") ' w2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\FundsCheck.xlsb") ' change the file path If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks, Workbooks(" ") Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Wb1.Worksheets.Item(1) ' Set Ws1 = Wb1.Worksheets("anything") ' sheet name can be anything Set Ws2 = Wb2.Worksheets.Item(1) ' ' Set Ws2 = Wb2.Worksheets("anything") Dim Lr1 As Long, Lc1 As Long Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. ) Let Lc1 = Ws1.Cells.Item(2, Ws1.Columns.Count).End(xlToLeft).Column Rem 2 Data ranges Dim arrOut() As String ReDim arrOut(1 To Lr1 - 1, 1 To 2) ' A 2 column array of as many rows as data in 1.xlsx We may not need all the rows Dim rngIn As Range Set rngIn = Ws1.Range(Ws1.Range("A1"), Ws1.Cells.Item(Lr1, Lc1)) Rem 3 Go through rows and columns in input data range Dim Rws As Long For Rws = 2 To Lr1 ' Go through rows in input data range Dim rngInRws As Range Set rngInRws = rngIn.Rows.Item(Rws) ' consider a row in the data range Dim Clms As Long ' go through columns in each row For Clms = 2 To Lc1 ' considering each column in the row under consideration If rngInRws.Cells.Item(Clms).Interior.Color = 65535 And rngInRws.Cells.Item(Clms).Value >= 5 Then ' ...if yellow highlighted colour data is greater than 5 or equal to 5 then Dim RwOut As Long ' a row in output array Let RwOut = RwOut + 1 ' a next new row in output array Let arrOut(RwOut, 1) = rngInRws.Cells.Item(1) ' The value in the first cell in the row under consideration is put in first column in output array Let arrOut(RwOut, 2) = rngInRws.Cells.Item(Clms).Value ' The value in the highlighted cell in the row under consideration is put in the second column of the output array Else ' Do nothing End If Next Clms Next Rws Rem 4 Output result Let Ws2.Range("A1:B" & Lr1 - 1 & "").Value = arrOut() ' A range of the dimensions of the output array has its values assigned to the values in the output arry End Sub

In support of this question
https://excelribbon.tips.net/T008884..._Into_One.html

Quote:

The full syntax of what Allen Wyatt is using is like …….
Cells(Rows.Count, 1).End(xlUp).Item(2) ……..
….
Item(2) will give us the cell just below the cell given by…….
Cells(Rows.Count, 1).End(xlUp) ………

Cells(Rows.Count, 1).End(xlUp) is the same as Cells(Rows.Count, 1).End(xlUp).Item(1) ………
……….
It is not to easy to explain how the items are assigned for a range……
See this demo

In the following demo, I show the item numbers for cells in four arbritrary ranges, A9 , B2:C3 , E5:G5 and D10:D12
As you will see, Item numbers are not restricted to just the range itself. The item numbers keep going. They go in a sequence of ... all columns in a row, ... then the next row ... etc....
The column count is determined by the original range, but the rows are not limited.

_Row\^Col
A

B

C

D

E

F

G

1

2
Item(1) Item(2)

3
Item(3) Item(4)

4
Item(5) Item(6)

5
Item(7) Item(8) Item(1) Item(2) Item(3)

6
Item(9) ….etc… Item(4) Item(5) Item(6)

7
Item(7) Item(8) Item(9)

8
Item(10) ….etc….

9
Item(1)

10
Item(2) Item(1)

11
Item(3) Item(2)

12
Item(4) Item(3)

13
Item(5) Item(4)

14
Item(6) Item(5)

15
…..etc…. Item(6)

16
Item(7)

17
Item(8)

18
Item(9)

19
Item(10)

20
….etc…

21

test Evaluate range for this post
http://www.excelfox.com/forum/showth...ecimals-by-vba

We can find the position of the . using Instr function https://docs.microsoft.com/en-us/off...instr-function

Then we can take the left of the number for a length equal to the position of the . + 3 using the Left function https://docs.microsoft.com/en-us/off.../left-function

Then we can remove the . using the Replace function , https://docs.microsoft.com/en-us/off...place-function

or formulas...

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

_Row\^Col
K

L

M

N

2

1090.699

3

147.965

4

264.4785

5

30.2495

6

7

8

5
1090.69 109069

9

4
147.96 14796

10

4
264.47 26447

11

3
30.24 3024

12

13

1090.699

14

147.965

15

264.4785

16

30.2495

Worksheet: 1-Sheet1
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )

_Row\^Col
K

L

M

N

2

1090.699

3

147.965

4

264.4785

5

30.2495

6

7

8

=FIND(".",K2)
=LEFT(K2,L8+2) =SUBSTITUTE(M8,".","")

9

=FIND(".",K3)
=LEFT(K3,L9+2) =SUBSTITUTE(M9,".","")

10

=FIND(".",K4)
=LEFT(K4,L10+2) =SUBSTITUTE(M10,".","")

11

=FIND(".",K5)
=LEFT(K5,L11+2) =SUBSTITUTE(M11,".","")

12

13

1090.699

14

147.965

15

264.4785

16

30.2495

Worksheet: 1-Sheet1
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )

_Row\^Col
L

M

N

O

8

=FIND(".",K2)
=LEFT(K2,L8+2) =SUBSTITUTE(M8,".","") =SUBSTITUTE(LEFT(K2,FIND(".",K2)+2),".","")

9

=FIND(".",K3)
=LEFT(K3,L9+2) =SUBSTITUTE(M9,".","") =SUBSTITUTE(LEFT(K3,FIND(".",K3)+2),".","")

10

=FIND(".",K4)
=LEFT(K4,L10+2) =SUBSTITUTE(M10,".","") =SUBSTITUTE(LEFT(K4,FIND(".",K4)+2),".","")

11

=FIND(".",K5)
=LEFT(K5,L11+2) =SUBSTITUTE(M11,".","") =SUBSTITUTE(LEFT(K5,FIND(".",K5)+2),".","")

Worksheet: 1-Sheet1

from Forulas, Evaluate Range

Code:

Sub EvaluateRangeTrimRemoveDot() ' http://www.excelfox.com/forum/showthread.php/2456-Remove-decimals-by-vba?p=13068#post13068 Dim Ws1 As Worksheet Set Ws1 = Workbooks("1.xls").Worksheets.Item(1) ' First worksheet in open workbooks 1.xls Dim LrK As Long: Let LrK = Ws1.Range("K" & Ws1.Rows.Count & "").End(xlUp).Row Dim RngK As Range: Set RngK = Ws1.Range("K2:K" & LrK & "") Let RngK.Value = Evaluate("=if({1},SUBSTITUTE(LEFT(" & RngK.Address & ",FIND("".""," & RngK.Address & ")+2),""."",""""))") End Sub

_Row\^Col	L	M	N	O
8	=FIND(".",K2)	=LEFT(K2,L8+2)	=SUBSTITUTE(M8,".","")	=SUBSTITUTE(LEFT(K2,FIND(".",K2)+2),".","")
9	=FIND(".",K3)	=LEFT(K3,L9+2)	=SUBSTITUTE(M9,".","")	=SUBSTITUTE(LEFT(K3,FIND(".",K3)+2),".","")
10	=FIND(".",K4)	=LEFT(K4,L10+2)	=SUBSTITUTE(M10,".","")	=SUBSTITUTE(LEFT(K4,FIND(".",K4)+2),".","")
11	=FIND(".",K5)	=LEFT(K5,L11+2)	=SUBSTITUTE(M11,".","")	=SUBSTITUTE(LEFT(K5,FIND(".",K5)+2),".","")

in support of this forum post
http://www.excelfox.com/forum/showth...ll=1#post13088

Explanation 1
In column K are numbers given to a maximum of 2 decimal places, for example
Column K
1090.69
147.95
264.47
30

The value in Column K must be adjusted so that it has the decimal format to 2 decimal places in steps of .05
So in this form, of like
…… 23.95 234 34.25 4.30 100.35 45.45 56.05 ……… etc….

So for example, in the above Column K test data, no adjustment is needed for 147.95 or 30
For 1090.69 and 264.47 some adjustment is needed. The adjustment could be to raise or lower the value. These are the possibilities:
change 1090.69 to 1090.65 or 1090.7
change 264.47 to 264.45 or 264.50

Which of the two adjustments is necessary will depend on the following:
If column H is greater than column D , then we adjust up .
If column H is lower than column D, then we adjust down .

Explanation 2
For all data rows, we compare column H to column D. If column H is greater than column D , then we adjust the value in column K up to the nearest multiple of .05. If column H is less than column D , then we adjust the value in column K down to the nearest multiple of .05. ( If the value in column K is an exact multiple of .05, then no action is to be taken )

For example
Before:

_Row\^Col
D

E

F

G

H

I

J

K

2

1087

1088

1077.25

1067.25

1079.9

25

10.799

1090.69

3

148.05

149.9

146.5

146

146.5

22

1.465

147.95

4

265

269.3

265

262.85

267.15

15083

2.6715

264.47

5

30.4

30.4

29.8

29.65

29.95

17388

0.2995

30

After:

_Row\^Col
D

E

F

G

H

I

J

K

L

2

1087

1088

1077.25

1067.25

1079.9

25

10.799

1090.65
This nuber is adjusted down

3

148.05

149.9

146.5

146

146.5

22

1.465

147.95
This number is not changed

4

265

269.3

265

262.85

267.15

15083

2.6715

264.5
This number is adjusted up

5

30.4

30.4

29.8

29.65

29.95

17388

0.2995

30
This number is not changed

Solution ( guess )

The previous formula solution already always adjust number down,

_Row\^Col
D

H

K

L

M

N

O

P

2

1087

1079.9

1090.69

21813.8

21813

1090.65

1090.65

1090.65

3

148.05

146.5

147.95

2959

2959

147.95

147.95

147.95

4

265

267.15

264.47

5289.4

5289

264.45

264.45

264.45

5

30.4

29.95

30

600

600

30

30

30

_Row\^Col
D

H

K

L

M

N

O

P

2

1087

1079.9

1090.69

=K2*100/5

=INT(L2)

=M2*5/100

=INT(L2)*5/100

=INT(K2*100/5)*5/100

3

148.05

146.5

147.95

=K3*100/5

=INT(L3)

=M3*5/100

=INT(L3)*5/100

=INT(K3*100/5)*5/100

4

265

267.15

264.47

=K4*100/5

=INT(L4)

=M4*5/100

=INT(L4)*5/100

=INT(K4*100/5)*5/100

5

30.4

29.95

30

=K5*100/5

=INT(L5)

=M5*5/100

=INT(L5)*5/100

=INT(K5*100/5)*5/100

So previous solution is correct if H < D
If H > D , the previous solution is .05 too small , so previous solution must be adjusted by +.05

=IF(H2<D2,INT(K2*100/5)*5/100,IF(H2>D2,(INT(K2*100/5)*5/100)+0.05,"H is equal to D"))

=IF(H3<D3,INT(K3*100/5)*5/100,IF(H3>D3,(INT(K3*100/5)*5/100)+0.05,"H is equal to D"))

=IF(H4<D4,INT(K4*100/5)*5/100,IF(H4>D4,(INT(K4*100/5)*5/100)+0.05,"H is equal to D"))

=IF(H5<D5,INT(K5*100/5)*5/100,IF(H5>D5,(INT(K5*100/5)*5/100)+0.05,"H is equal to D"))

But we must also check if number is already exact multiple of .05
Like if ( integer (value/.05)) – value/.05) = 0
( Excel has errors and bugs, and may give a very small number when it should give us 0, so we must do a trick-
if Round ( ( integer (value/.05)) – value/.05) ) = 0 )
So:

=IF(ROUND(INT(K2/0.05)-(K2/0.05),2)=0,K2,IF(H2<D2,INT(K2*100/5)*5/100,IF(H2>D2,(INT(K2*100/5)*5/100)+0.05,"H is equal to D")))

=IF(ROUND(INT(K3/0.05)-(K3/0.05),2)=0,K3,IF(H3<D3,INT(K3*100/5)*5/100,IF(H3>D3,(INT(K3*100/5)*5/100)+0.05,"H is equal to D")))

=IF(ROUND(INT(K4/0.05)-(K4/0.05),2)=0,K4,IF(H4<D4,INT(K4*100/5)*5/100,IF(H4>D4,(INT(K4*100/5)*5/100)+0.05,"H is equal to D")))

=IF(ROUND(INT(K5/0.05)-(K5/0.05),2)=0,K5,IF(H5<D5,INT(K5*100/5)*5/100,IF(H5>D5,(INT(K5*100/5)*5/100)+0.05,"H is equal to D")))

1090.65

147.95

264.5

30

_Row\^Col	D	E	F	G	H	I	J	K
2	1087	1088	1077.25	1067.25	1079.9	25	10.799	1090.69
3	148.05	149.9	146.5	146	146.5	22	1.465	147.95
4	265	269.3	265	262.85	267.15	15083	2.6715	264.47
5	30.4	30.4	29.8	29.65	29.95	17388	0.2995	30

_Row\^Col	D	E	F	G	H	I	J	K	L
2	1087	1088	1077.25	1067.25	1079.9	25	10.799	1090.65	This nuber is adjusted down
3	148.05	149.9	146.5	146	146.5	22	1.465	147.95	This number is not changed
4	265	269.3	265	262.85	267.15	15083	2.6715	264.5	This number is adjusted up
5	30.4	30.4	29.8	29.65	29.95	17388	0.2995	30	This number is not changed

_Row\^Col	D	H	K	L	M	N	O	P
2	1087	1079.9	1090.69	21813.8	21813	1090.65	1090.65	1090.65
3	148.05	146.5	147.95	2959	2959	147.95	147.95	147.95
4	265	267.15	264.47	5289.4	5289	264.45	264.45	264.45
5	30.4	29.95	30	600	600	30	30	30

_Row\^Col	D	H	K	L	M	N	O	P
2	1087	1079.9	1090.69	=K2*100/5	=INT(L2)	=M2*5/100	=INT(L2)*5/100	=INT(K2100/5)5/100
3	148.05	146.5	147.95	=K3*100/5	=INT(L3)	=M3*5/100	=INT(L3)*5/100	=INT(K3100/5)5/100
4	265	267.15	264.47	=K4*100/5	=INT(L4)	=M4*5/100	=INT(L4)*5/100	=INT(K4100/5)5/100
5	30.4	29.95	30	=K5*100/5	=INT(L5)	=M5*5/100	=INT(L5)*5/100	=INT(K5100/5)5/100

VBA Solution to above, and answer to this Post
http://www.excelfox.com/forum/showth...ll=1#post13102

VBA answer

Put columns in arrays

_Row\^Col
D

1
Open

2

1087

3

148.05

4

265

5

30.4

arrD() =

1087

148.05

265

30.4

_Row\^Col
H

1
LTP

2

1079.9

3

146.5

4

267.15

5

29.95

arrH() =

1079.9

146.5

267.15

29.95

_Row\^Col
K

1

2

1090.69

3

147.95

4

264.47

5

30

arrK() ( initial ) =

1090.69

147.95

264.47

30

The macro below manipulates the contents of arrK() as per the question requirement, then pastes the modified array over the initial values

Code:

Sub ChangeSecondNumberAfterDecimalConditionally() ' http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally Rem 1 Worksheets info Dim Wb1 As Workbook Set Wb1 = Workbooks("SAMPLE1 18Apr2020.xlsx") ' Workbooks("1.xls") ' CHANGE TO SUIT Dim Ws1 As Worksheet Set Ws1 = Wb1.Worksheets.Item(1) Dim Lrow As Long Let Lrow = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. ) Rem 2 ranges of interest, D H and K , are placed in 1 column arrays, rows from 2 to Lrow Dim arrD() As Variant, arrH() As Variant, ArrK() As Variant ' The .Value property used below returns its values in a field of variant type elements, so to avoiud a type mismatch we must Dim here appropriately Let arrD() = Ws1.Range("D2:D" & Lrow & "").Value: Let arrH() = Ws1.Range("H2:H" & Lrow & "").Value: Let ArrK() = Ws1.Range("K2:K" & Lrow & "").Value Rem 3 Manipulate arrK() as per requiremnt For all data rows, we compare column H to column D. If column H is greater than column D , then we adjust the value in column K up to the nearest multiple of .05. If column H is less than column D , then we adjust the value in column K down to the nearest multiple of .05. ( If the value in column K is an exact multiple of .05, then no action is to be taken ) http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally?p=13099&viewfull=1#post13099 Dim Cnt For Cnt = 1 To Lrow - 1 ' range is row 2 to Lrow-1, array will be 1 to Lrow-1 If Int(Round((ArrK(Cnt, 1) / 0.05), 2)) - Round((ArrK(Cnt, 1) / 0.05), 2) = 0 Then ' do nothing because we have exact mulktiple of .05 Else ' case K is not an exact multiple of .05 If arrH(Cnt, 1) < arrD(Cnt, 1) Then Let ArrK(Cnt, 1) = Int(ArrK(Cnt, 1) * 100 / 5) * 5 / 100 ' =INT(K2*100/5)*5/100 =K2*100/5 =INT(L2) =M2*5/100 =INT(L2)*5/100 =INT(K2*100/5)*5/100 http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally?p=13100&viewfull=1#post13100 ElseIf arrH(Cnt, 1) > arrD(Cnt, 1) Then Let ArrK(Cnt, 1) = (Int(ArrK(Cnt, 1) * 100 / 5) * 5 / 100) + 0.05 Else ' case H = D Let ArrK(Cnt, 1) = "H is equal to D" End If End If Next Cnt Rem 4 Paste out modified array over original values Let Ws1.Range("K2:K" & Lrow & "").Value = ArrK() End Sub

After running that macro the arrK() contents change to

1090.65

147.95

264.5

30

And that is then pasted out into the range

_Row\^Col
K

1

2

1090.65

3

147.95

4

264.5

5

30

_Row\^Col	D
1	Open
2	1087
3	148.05
4	265
5	30.4

_Row\^Col	H
1	LTP
2	1079.9
3	146.5
4	267.15
5	29.95

_Row\^Col	K
1
2	1090.69
3	147.95
4	264.47
5	30

_Row\^Col	K
1
2	1090.65
3	147.95
4	264.5
5	30

In support of this Thread
http://www.excelfox.com/forum/showth...d-paste-by-vba

1.xls

Code:

A B C D E F G H I J K L Exchange Symbol Series/Expiry Open High Low Prev Close LTP NSE ACC EQ 1182 1193 1151.7 1156.6 1156.6 22 11.566 116815 1168.166 NSE ADANIENT EQ 137.15 140.55 134.1 134.65 134.65 25 1.3465 13595 135.9965 NSE ADANIPORTS EQ 273.95 276.95 269.55 270.65 270.65 15083 2.7065 27335 273.3565 NSE ADANIPOWER EQ 32.3 32.35 30.45 30.65 30.65 17388 0.3065 3095 30.9565 NSE AMARAJABAT EQ 555 555 529.25 532.1 532.1 100 5.321 5374 537.421 NSE ASIANPAINT EQ 1815.05 1842.8 1814 1827.55 1827.55 236 18.2755 18093 1809.2745 NSE AMBUJACEM EQ 169.9 171.6 166.2 167.95 167.95 1270 1.6795 1696 169.6295 NSE APOLLOHOSP EQ 1360 1377.5 1341.1 1359.5 1359.5 157 13.595 137305 1373.095 NSE APOLLOPIPE EQ 277.55 284 277.4 280.15 280.15 14361 2.8015 27735 277.3485 NSE ASHOKLEY EQ 46 46.3 44.6 44.95 44.95 212 0.4495 4535 45.3995 NSE AUROPHARMA EQ 629.05 654.5 618.5 624.45 624.45 275 6.2445 63065 630.6945 NSE AXISBANK EQ 416 419.65 401.25 403.95 403.95 5900 4.0395 40795 407.9895 NSE BAJAJ-AUTO EQ 2410 2472 2381 2445.35 2445.35 16669 24.4535 24209 2420.8965 NSE BAJAJFINSV EQ 4675 4675 4365 4389.8 4389.8 16675 43.898 443365 4433.698 NSE BAJFINANCE EQ 2113.5 2113.5 1970.05 1976.25 1976.25 317 19.7625 199601.25 1996.0125 NSE BALKRISIND EQ 879 887.5 856.7 867.75 867.75 335 8.6775 8764 876.4275 NSE BANKBARODA EQ 47.65 48 46.1 46.35 46.35 4668 0.4635 468 46.8135 NSE BATAINDIA EQ 1258 1313 1230 1239.55 1239.55 371 12.3955 12519 1251.9455 NSE BEL EQ 75.1 77.7 73.35 74.55 74.55 383 0.7455 7525 75.2955 NSE BERGEPAINT EQ 521 535 515 519.7 519.7 404 5.197 52485 524.897 NSE BHARATFORG EQ 251.1 265 251.1 263.25 263.25 422 2.6325 26065 260.6175 NSE BHARTIARTL EQ 494.9 499 484.45 494.25 494.25 10604 4.9425 49915 499.1925 NSE BHEL EQ 21.1 21.4 20.6 20.65 20.65 438 0.2065 2085 20.8565 NSE BIOCON EQ 346 360 339 357.4 357.4 11373 3.574 35385 353.826 NSE BOSCHLTD EQ 10470 10500 10100 10212.45 10212.45 2181 102.1245 1031455 10314.5745 NSE BPCL EQ 352 356.65 347 350.45 350.45 526 3.5045 35395 353.9545 NSE BRITANNIA EQ 2980 3122.9 2956 3062.15 3062.15 547 30.6215 303155 3031.5285 NSE CADILAHC EQ 333.25 344 330.9 336.95 336.95 7929 3.3695 3336 333.5805 NSE CANBK EQ 82.55 84.7 81.05 81.35 81.35 10794 0.8135 8215 82.1635 NSE CASTROLIND EQ 124.15 127 119.3 120.7 120.7 1250 1.207 1219 121.907 NSE CENTURYTEX EQ 289.2 298.5 282 284.05 284.05 625 2.8405 28685 286.8905 NSE CESC EQ 603 609.5 590.95 596.75 596.75 628 5.9675 6027 602.7175 NSE CHOLAFIN EQ 145 145.8 132.05 132.9 132.9 685 1.329 1342 134.229 NSE CIPLA EQ 586.4 606 583.6 599.3 599.3 694 5.993 59335 593.307 NSE COALINDIA EQ 140.6 143.8 135.8 137 137 20374 1.37 13835 138.37 NSE COLPAL EQ 1470 1497.95 1463.6 1483.65 1483.65 15141 14.8365 146885 1468.8135 NSE CONCOR EQ 368 376.6 359.5 361.1 361.1 4749 3.611 3647 364.711 NSE CUMMINSIND EQ 420.95 426.55 377.25 384.95 384.95 1901 3.8495 38875 388.7995 NSE DABUR EQ 499 503.75 494.5 499.05 499.05 772 4.9905 4941 494.0595 NSE DISHTV EQ 5.1 5.15 4.75 4.75 4.75 0.0475 475 4.7975 NSE DIVISLAB EQ 2410 2460 2390.6 2425.4 2425.4 10940 24.254 240115 2401.146 NSE DLF EQ 135 135 127.6 128.2 128.2 14732 1.282 12945 129.482 NSE DRREDDY EQ 4010 4049.6 3970.1 4002.8 4002.8 881 40.028 40428 4042.828 NSE EICHERMOT EQ 14068 14091 13505.1 13589.2 13589.2 910 135.892 1372505 13725.092 NSE EQUITAS EQ 53.85 56.4 50.65 51.05 51.05 16852 0.5105 5155 51.5605 NSE ESCORTS EQ 744 758.7 712.2 717 717 958 7.17 72415 724.17 NSE EXIDEIND EQ 146.3 151.8 145.15 148.45 148.45 676 1.4845 14696.55 146.9655 NSE FEDERALBNK EQ 44 44.2 42.9 43.1 43.1 1023 0.431 435 43.531 NSE GAIL EQ 82.95 84.25 79 81.5 81.5 4717 0.815 823 82.315 NSE GLENMARK EQ 342.7 360.95 342 344.85 344.85 7406 3.4485 34145 341.4015 NSE GMRINFRA EQ 17.5 17.5 17 17.15 17.15 13528 0.1715 173 17.3215 NSE GODREJCP EQ 536.95 547.1 530.05 534.4 534.4 10099 5.344 5397 539.744 NSE GRASIM EQ 492 501.9 484.75 499.05 499.05 1232 4.9905 4941 494.0595 NSE HAVELLS EQ 524 537 517.1 525.6 525.6 9819 5.256 52035 520.344 NSE HCLTECH EQ 480 496.9 465.15 468.1 468.1 7229 4.681 47275 472.781 NSE HDFC EQ 1603 1624.95 1569.1 1580.3 1580.3 1330 15.803 15961 1596.103 NSE HDFCBANK EQ 933 958.4 926 938.05 938.05 1333 9.3805 9287 928.6695 NSE HEROMOTOCO EQ 1842.5 1939.4 1840 1894.8 1894.8 1348 18.948 18759 1875.852 NSE HINDALCO EQ 109.95 109.95 102.85 103.65 103.65 1363 1.0365 10465 104.6865 NSE HINDPETRO EQ 208.75 208.75 200 201.4 201.4 1406 2.014 2034 203.414 NSE HINDUNILVR EQ 2311 2338 2280 2283.1 2283.1 1394 22.831 23059 2305.931 NSE IBULHSGFIN EQ 114 118.4 111 112.95 112.95 30125 1.1295 11405 114.0795 NSE ICICIBANK EQ 337.9 343.25 331.5 334.85 334.85 4963 3.3485 33815 338.1985 NSE ICICIPRULI EQ 348 356.8 329.4 336.55 336.55 18652 3.3655 3399 339.9155 NSE IDEA EQ 4.25 4.25 3.95 4 4 14366 0.04 404 4.04 NSE IDFCFIRSTB EQ 23.35 23.4 22.1 22.2 22.2 11184 0.222 224 22.422 NSE IGL EQ 446 455.7 430 437.25 437.25 11262 4.3725 4416 441.6225 NSE INDIGO EQ 930 938.55 878.75 891.75 891.75 11195 8.9175 90065 900.6675 NSE INDUSINDBK EQ 392.25 399.9 380 382.9 382.9 5258 3.829 3867 386.729 NSE INFRATEL EQ 169 172.9 149.5 152 152 29135 1.52 1535 153.52 NSE INFY EQ 668.55 675 654.8 658 658 1594 6.58 66455 664.58 NSE IOC EQ 82.25 84.4 81.1 81.5 81.5 1624 0.815 823 82.315 NSE ITC EQ 181 182.8 179.3 180.05 180.05 1660 1.8005 18185 181.8505 NSE JINDALSTEL EQ 85 87 78.25 79.15 79.15 6733 0.7915 799 79.9415 NSE JSWSTEEL EQ 157.5 159.5 152.6 153.25 153.25 11723 1.5325 15475 154.7825 NSE JUBLFOOD EQ 1484 1494.7 1444.45 1478.7 1478.7 18096 14.787 149345 1493.487 NSE JUSTDIAL EQ 343 349.85 327 329.8 329.8 29962 3.298 33305 333.098 NSE KOTAKBANK EQ 1219 1258 1213.35 1239.55 1239.55 1922 12.3955 12272 1227.1545 NSE L&TFH EQ 58.5 60.2 58.05 58.95 58.95 24948 0.5895 584 58.3605 NSE LICHSGFIN EQ 280 281 259.15 260.65 260.65 1997 2.6065 26325 263.2565 NSE LT EQ 838 869 834.15 851.2 851.2 11483 8.512 8427 842.688 NSE LUPIN EQ 824.7 891 820.7 877.35 877.35 10440 8.7735 8686 868.5765 NSE M&M EQ 342 344.75 332 334.3 334.3 2031 3.343 3376 337.643 NSE M&MFIN EQ 150 150 138.2 140.45 140.45 13285 1.4045 14185 141.8545 NSE MANAPPURAM EQ 106 108.1 104.05 107.1 107.1 19061 1.071 10605 106.029 NSE MARICO EQ 300.9 309.55 300 306.1 306.1 4067 3.061 30305 303.039 NSE MARUTI EQ 5100 5140 5030 5045.65 5045.65 10999 50.4565 50961 5096.1065 NSE MCDOWELL-N EQ 524.9 527.9 516.7 519.5 519.5 10447 5.195 52465 524.695 NSE MFSL EQ 415 432.75 400.55 420.15 420.15 2142 4.2015 41595 415.9485 NSE MGL EQ 912 936.95 890 913.05 913.05 17534 9.1305 90395 903.9195 NSE MINDTREE EQ 770.75 785 755 780.35 780.35 14356 7.8035 77255 772.5465 NSE MOTHERSUMI EQ 72.4 74.25 71.35 72 72 4204 0.72 727 72.72 NSE MRF EQ 58225 59200 58000 58805.4 58805.4 2277 588.054 5821735 58217.346 NSE MUTHOOTFIN EQ 809.4 834 798.05 813.95 813.95 23650 8.1395 80585 805.8105 NSE NATIONALUM EQ 33.75 34.9 30.55 31.5 31.5 6364 0.315 318 31.815 NSE NBCC EQ 20.5 20.6 18.9 19.25 19.25 31415 0.1925 194 19.4425 NSE NCC EQ 25.45 25.8 24.4 24.6 24.6 2319 0.246 248 24.846 NSE NESTLEIND EQ 17300 17800 17300 17406.05 17406.05 17963 174.0605 1723198.95 17231.9895 NSE NIITTECH EQ 1181 1199 1085.25 1116.1 1116.1 11543 11.161 112725 1127.261 NSE NMDC EQ 76.7 77.9 73.4 73.8 73.8 15332 0.738 745 74.538 NSE NTPC EQ 94.75 96.35 91.95 93.4 93.4 11630 0.934 943 94.334 NSE OIL EQ 86 88.6 83.5 83.85 83.85 17438 0.8385 8465 84.6885 NSE ONGC EQ 67.15 69.5 66.6 67.6 67.6 2475 0.676 6695 66.924 NSE PAGEIND EQ 17550 17970 17460 17854.35 17854.35 14413 178.5435 1767585 17675.8065 NSE PEL EQ 815 877.45 808.1 864.45 864.45 2412 8.6445 85585 855.8055 NSE PETRONET EQ 220 222.95 215.75 218.5 218.5 11351 2.185 22065 220.685 NSE PFC EQ 90.7 94.35 89.6 91.05 91.05 14299 0.9105 9015 90.1395 NSE PIDILITIND EQ 1532.1 1576.8 1500.15 1505.2 1505.2 2664 15.052 152025 1520.252 NSE PNB EQ 30.7 31.1 30.15 30.2 30.2 10666 0.302 305 30.502 NSE POWERGRID EQ 157 160.1 155.75 159.15 159.15 14977 1.5915 1576 157.5585 NSE PVR EQ 973 989.4 950 954.6 954.6 13147 9.546 9641 964.146 NSE RAMCOCEM EQ 569.5 584.4 534 538.05 538.05 2043 5.3805 5434 543.4305 NSE RBLBANK EQ 104.5 110.7 101.7 107.15 107.15 18391 1.0715 1061 106.0785 NSE RECLTD EQ 90.65 93.4 89.1 89.35 89.35 15355 0.8935 902 90.2435 NSE RELIANCE EQ 1350.15 1494.95 1347.2 1417 1417 2885 14.17 140285 1402.83 NSE SAIL EQ 26 27.35 25.8 26.9 26.9 2963 0.269 2665 26.631 NSE SBIN EQ 184 184 179 179.75 179.75 3045 1.7975 1815 181.5475 NSE SHREECEM EQ 18739 18927.3 18382.55 18587.45 18587.45 3103 185.8745 187733 18773.3245 NSE SIEMENS EQ 1159 1203.7 1135 1145.9 1145.9 3150 11.459 115735 1157.359 NSE SRF EQ 3602 3660.8 3470 3488.05 3488.05 3273 34.8805 35229 3522.9305 NSE SRTRANSFIN EQ 610 699 579.25 668.2 668.2 4306 6.682 66155 661.518 NSE SUNPHARMA EQ 476.95 497 473.55 485.55 485.55 3351 4.8555 4807 480.6945 NSE SUNTV EQ 368.7 385.45 366.5 376.9 376.9 13404 3.769 37315 373.131 NSE TATACHEM EQ 263.4 273 255.35 270.05 270.05 3405 2.7005 26735 267.3495 NSE TATAMOTORS EQ 75 76.9 74 74.2 74.2 3456 0.742 749 74.942 NSE TATAMTRDVR EQ 34.3 34.95 33.5 33.7 33.7 16965 0.337 3403.7 34.037 NSE TATAPOWER EQ 32.6 32.6 30.8 31.05 31.05 3426 0.3105 3135 31.3605 NSE TATASTEEL EQ 266.3 273.85 264.45 267.55 267.55 3499 2.6755 2649 264.8745 NSE TCS EQ 1840.7 1851.95 1807.8 1818.55 1818.55 11536 18.1855 18367 1836.7355 NSE TECHM EQ 522 532.6 502.1 503.45 503.45 13538 5.0345 50845 508.4845 NSE TITAN EQ 910 926.9 893.1 906.05 906.05 3506 9.0605 9151 915.1105 NSE TORNTPHARM EQ 2430 2488 2361.65 2430.5 2430.5 3518 24.305 24062 2406.195 NSE TORNTPOWER EQ 297.5 307.9 296.65 303.8 303.8 13786 3.038 3008 300.762 NSE TVSMOTOR EQ 298 302 289.05 297 297 8479 2.97 29995 299.97 NSE UBL EQ 921 922.5 863.85 880.75 880.75 16713 8.8075 88955 889.5575 NSE UJJIVAN EQ 170 173.5 161.6 164.1 164.1 17069 1.641 1657 165.741 NSE ULTRACEMCO EQ 3410 3440 3292.8 3307.95 3307.95 11532 33.0795 334102.95 3341.0295 NSE UPL EQ 345 347.6 334.2 335.85 335.85 11287 3.3585 3392 339.2085 NSE VEDL EQ 76.8 80.25 75.7 77.95 77.95 3063 0.7795 772 77.1705 NSE VOLTAS EQ 500 505 485 487.15 487.15 3718 4.8715 49202.15 492.0215 NSE WIPRO EQ 179.95 180.8 177.15 177.75 177.75 3787 1.7775 1795 179.5275 NSE ZEEL EQ 150.8 152.85 143 145.15 145.15 3812 1.4515 1466 146.6015

Shortened
http://www.excelfox.com/forum/showth...ll=1#post13126
_____ Workbook: 1 26Apr.xls ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

H

I

J

K

L

1
Exchange Symbol Series/Expiry Open High Low Prev Close LTP

2
NSE ACC EQ
1182

1193

1151.7

1156.6

1156.6

22

11.566

116815

1168.166

3
NSE ADANIENT EQ
137.15

140.55

134.1

134.65

134.65

25

1.3465

13595

135.9965

4
NSE ADANIPORTS EQ
273.95

276.95

269.55

270.65

270.65

15083

2.7065

27335

273.3565

5
NSE ADANIPOWER EQ
32.3

32.35

30.45

30.65

30.65

17388

0.3065

3095

30.9565

6
NSE AMARAJABAT EQ
555

575

529.25

532.1

570.1

100

5.321

5374

537.421

Worksheet: 1-Sheet1

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ACC	EQ	1182	1193	1151.7	1156.6	1156.6	22	11.566	116815	1168.166
3	NSE	ADANIENT	EQ	137.15	140.55	134.1	134.65	134.65	25	1.3465	13595	135.9965
4	NSE	ADANIPORTS	EQ	273.95	276.95	269.55	270.65	270.65	15083	2.7065	27335	273.3565
5	NSE	ADANIPOWER	EQ	32.3	32.35	30.45	30.65	30.65	17388	0.3065	3095	30.9565
6	NSE	AMARAJABAT	EQ	555	575	529.25	532.1	570.1	100	5.321	5374	537.421

1 Attachment(s)

From last post
Before
_____ Workbook: Alert.txt ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

1
NSE
14361

6
A

2
NSE
25

6
A

3
NSE
15083

6
A

4
NSE
17388

6
A

5
NSE
100

6
A

6
NSE
22

6
A

7

Worksheet: Alert

Quote:

check wheather column H of 1.xls is greater or lower than column D of 1.xls

if column H of 1.xls is greater than column D of 1.xls then match column I of 1.xls with column B of 2.csv & if it matches then put this symbol "<" in column D of 2.csv & copy paste the data of column K of 1.xls in column E of 2.csv

or

if column H of 1.xls is lower than column D of 1.xls then match column I of 1.xls with column B of 2.csv & if it matches then put this symbol ">" in column D of 2.csv & copy paste the data of column K of 1.xls in column E of 2.csv

Run macro ( from here https://www.ozgrid.com/forum/index.p...54#post1233954 )

Code:

Sub STEP8() ' http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13126&viewfull=1#post13126 Dim Wb1 As Workbook, Wb2 As Workbook Dim Ws1 As Worksheet, Ws2 As Worksheet Dim rg1 As Range, i As Long, c As Range Set Wb1 = Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") Set Wb2 = Workbooks("Alert.txt") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Alert..csv") Set Ws1 = Wb1.Worksheets.Item(1) Set Ws2 = Wb2.Worksheets.Item(1) Set rg1 = Ws1.Cells(1, 1).CurrentRegion With rg1 For i = 2 To rg1.Rows.Count If .Cells(i, 8) > .Cells(i, 4) Then ' if column H of 1.xls is greater than column D of 1.xls Set c = Ws2.Columns(2).Find(.Cells(i, 9)) ' match column I of 1.xls with column B of 2.csv If Not c Is Nothing Then 'if match found c.Offset(, 2).Value = "<" ' put this symbol "<" in column D of 2 c.Offset(, 3).Value = .Cells(i, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv End If Else ' if column H of 1.xls is lower than column D of 1.xls Set c = Ws2.Columns(2).Find(.Cells(i, 9)) ' match column I of 1.xls with column B of 2.csv If Not c Is Nothing Then 'if match found c.Offset(, 2).Value = ">" ' then put this symbol ">" in column D of 2.csv c.Offset(, 3).Value = .Cells(i, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv End If End If Next i End With End Sub

After - results after running macro above

_____ Workbook: Alert.txt ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

1
NSE
14361

6
A

2
NSE
25

6
>
13595
A

3
NSE
15083

6
>
27335
A

4
NSE
17388

6
>
3095
A

5
NSE
100

6
<
5374
A

6
NSE
22

6
>
116815
A

7

Worksheet: Alert

1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
macro.xlsm : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt
Alert.csv : https://app.box.com/s/4ejptbaggn67nc91yz9jhgcefm2qae0r

_Row\^Col	A	B	C	F
1	NSE	14361	6	A
2	NSE	25	6	A
3	NSE	15083	6	A
4	NSE	17388	6	A
5	NSE	100	6	A
6	NSE	22	6	A
7

_Row\^Col	A	B	C	D	E	F
1	NSE	14361	6			A
2	NSE	25	6	>	13595	A
3	NSE	15083	6	>	27335	A
4	NSE	17388	6	>	3095	A
5	NSE	100	6	<	5374	A
6	NSE	22	6	>	116815	A
7

In support of this post
http://www.excelfox.com/forum/showth...ll=1#post13131
It is not necessary to have all data to demonstrate the problem!!

Quote:

Originally Posted by DocAElstein

....It is difficult in a forum to work with many rows.
Reduce the rows
We need just enough data to test.
Pick your test data carefully.
Just use a few rows. But pick your test data carefully so that it test all scenarios....

Quote:

Originally Posted by DocAElstein

....make a small file with also row data that errors.
Explain again and show me what and where the errors are….

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

_Row\^Col
A

B

C

D

E

F

G

H

I

J

K

L

M

1
Exchange Symbol Series/Expiry Open High Low Prev Close LTP

2
NSE ACC EQ
1182

1193

1151.7

1190.45

1156.6

22

11.566

116815

1168.166

3
NSE DABUR EQ
499

503.75

494.5

499

499.05

772

4.9905

4941

494.0595

4
NSE DISHTV EQ
5.1

5.15

4.75

4.95

4.75

0.0475

475

4.7975

5
NSE UBL EQ
921

922.5

863.85

920

880.75

16713

8.8075

88955

889.5575

6
NSE UJJIVAN EQ
170

173.5

161.6

179.55

164.1

17069

1.641

1657

165.741

7
NSE VEDL EQ
76.8

80.25

75.7

77.6

77.95

3063

0.7795

772

77.1705

8
NSE VOLTAS EQ
500

505

485

508.2

487.15

3718

4.8715

49202.15

492.0215

9
NSE ZEEL EQ
150.8

152.85

143

157.55

145.15

3812

1.4515

1466

146.6015

10

11

12

Worksheet: 1-Sheet1 27Apr_2

Before

_____ Workbook: Alert.csv ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

1
NSE
25

6
A

2
NSE
3812

6
A

3
NSE
15083

6
A

4
NSE
22

6
A

5

Worksheet: Alert.

Run macro, then we have After results:

_____ Workbook: Alert.csv ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

1
NSE
25

6
A

2
NSE
3812

6
>
1466
A

3
NSE
15083

6
A

4
NSE
22

6
>
116815
A

5
>
475

Worksheet: Alert.

match column I of 1.xls with column B of 2.csv

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

_Row\^Col
F

G

H

I

J

1
Low Prev Close LTP

2

1151.7

1190.45

1156.6

22

11.566

3

494.5

499

499.05

772

4.9905

4

4.75

4.95

4.75

0.0475

5

863.85

920

880.75

16713

8.8075

6

161.6

179.55

164.1

17069

1.641

_____ Workbook: Alert.csv ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

3
NSE
15083

6

4
NSE
22

6

5

6

match column I of 1.xls with column B of 2.csv
column I of 1.xls is Empty
column B of 2.csv is Empty
Empty = Empty = Match

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

_Row\^Col
F

G

H

I

J

1
Low Prev Close LTP

2

1151.7

1190.45

1156.6

22

11.566

3

494.5

499

499.05

772

4.9905

4

4.75

4.95

4.75
Empty
0.0475

5

863.85

920

880.75

16713

8.8075

6

161.6

179.55

164.1

17069

1.641

_____ Workbook: Alert.csv ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

3
NSE
15083

6

4
NSE
22

6

5
Empty

6

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ACC	EQ	1182	1193	1151.7	1190.45	1156.6	22	11.566	116815	1168.166
3	NSE	DABUR	EQ	499	503.75	494.5	499	499.05	772	4.9905	4941	494.0595
4	NSE	DISHTV	EQ	5.1	5.15	4.75	4.95	4.75		0.0475	475	4.7975
5	NSE	UBL	EQ	921	922.5	863.85	920	880.75	16713	8.8075	88955	889.5575
6	NSE	UJJIVAN	EQ	170	173.5	161.6	179.55	164.1	17069	1.641	1657	165.741
7	NSE	VEDL	EQ	76.8	80.25	75.7	77.6	77.95	3063	0.7795	772	77.1705
8	NSE	VOLTAS	EQ	500	505	485	508.2	487.15	3718	4.8715	49202.15	492.0215
9	NSE	ZEEL	EQ	150.8	152.85	143	157.55	145.15	3812	1.4515	1466	146.6015
10
11
12

_Row\^Col	A	B	C	F
1	NSE	25	6	A
2	NSE	3812	6	A
3	NSE	15083	6	A
4	NSE	22	6	A
5

_Row\^Col	A	B	C	D	E	F
1	NSE	25	6			A
2	NSE	3812	6	>	1466	A
3	NSE	15083	6			A
4	NSE	22	6	>	116815	A
5				>	475

_Row\^Col	F	G	H	I	J
1	Low	Prev Close	LTP
2	1151.7	1190.45	1156.6	22	11.566
3	494.5	499	499.05	772	4.9905
4	4.75	4.95	4.75		0.0475
5	863.85	920	880.75	16713	8.8075
6	161.6	179.55	164.1	17069	1.641

_Row\^Col	A	B	C
3	NSE	15083	6
4	NSE	22	6
5
6

_Row\^Col	F	G	H	I	J
1	Low	Prev Close	LTP
2	1151.7	1190.45	1156.6	22	11.566
3	494.5	499	499.05	772	4.9905
4	4.75	4.95	4.75	Empty	0.0475
5	863.85	920	880.75	16713	8.8075
6	161.6	179.55	164.1	17069	1.641

_Row\^Col	A	B	C
3	NSE	15083	6
4	NSE	22	6
5		Empty
6

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

Explanation of the problem
The error is caused by bad understanding of Range.Find Method ( https://docs.microsoft.com/de-de/off...cel.range.find )

We only need small amount of test data to demonstrate the problem:
Consider the results of this test data

Before:

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

_Row\^Col
A

B

C

D

E

F

G

H

I

J

K

L

M

1
Exchange Symbol Series/Expiry Open High Low Prev Close LTP

2
NSE ACC EQ
1182

1193

1151.7

1190.45

1156.6

22

11.566

116815

1168.166

3
NSE ADANIENT EQ
137.15

140.55

134.1

140.5

134.65

25

1.3465

13595

135.9965

4
NSE ADANIPORTS EQ
273.95

276.95

269.55

277.6

270.65

15083

2.7065

27335

273.3565

5

Worksheet: 1-Sheet1 27Apr_2 (2)

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

_Row\^Col
A

B

C

D

E

F

1
NSE
25

6
A

2
NSE
17388

6
A

3
NSE
404

6
A

4
NSE
422

6
A

5
NSE
10604

6
A

6
NSE
438

6
A

7
NSE
10794

6
A

8
NSE
1250

6
A

9
NSE
625

6
A

10
NSE
15083

6
A

11
NSE
22

6
A

12

Worksheet: Alert.

results After
_____ Workbook: AlertTestData.xlsx ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

1
NSE
25

6
A

2
NSE
17388

6
A

3
NSE
404

6
A

4
NSE
422

6
>
116815
A

5
NSE
10604

6
A

6
NSE
438

6
A

7
NSE
10794

6
A

8
NSE
1250

6
>
13595
A

9
NSE
625

6
A

10
NSE
15083

6
>
27335
A

11
NSE
22

6
A

12

Worksheet: Alert.

Those results come from using this macro here: http://www.excelfox.com/forum/showth...ll=1#post13143
Those results arise due to this problem code line
Ws2.Columns(2).Find(.Cells(i, 9))

That code line is only using one argument for Range.Find Method
So VBA must guess the others. It has guessed not what we want. It has guessed similar to this
Ws2.Columns(2).Find(What:=.Cells(i, 9), After:=B1, LookAt:xlpart)

Because of After:=B1 , it starts to look from B2 in
Because of LookAt:xlpart , we will look for what we want anywhere inside a cell, so if we are looking for the number 25 , then all these numbers or even text could be a match
4567256
2500
25
564rghsseeffzz25adksfhaejh
VBA will choose the first match that it finds

For example, for our 25 it started looking from B2 in Worksheet Alert, and the first it found was 1250

For large data, there will be many errors caused by this problem. But the problem and the solution will be the same.
It is easier to demonstrate the problem with small test data.
It is easier to test a solution with small test data.

It is the responsibility of the person finally responsible for the macros in real use to take the time to check for larger amounts of real data. For getting free help in a forum , this will be the responsibility of the persom getting help.

Share ‘1.xls’ : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
Share ‘AlertTestData.xlsx’ : https://app.box.com/s/nhdxcq0ulxldebanz1lz49wr1stf1pc4
Share ‘macro.xlsm’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ACC	EQ	1182	1193	1151.7	1190.45	1156.6	22	11.566	116815	1168.166
3	NSE	ADANIENT	EQ	137.15	140.55	134.1	140.5	134.65	25	1.3465	13595	135.9965
4	NSE	ADANIPORTS	EQ	273.95	276.95	269.55	277.6	270.65	15083	2.7065	27335	273.3565
5

_Row\^Col	A	B	C	F
1	NSE	25	6	A
2	NSE	17388	6	A
3	NSE	404	6	A
4	NSE	422	6	A
5	NSE	10604	6	A
6	NSE	438	6	A
7	NSE	10794	6	A
8	NSE	1250	6	A
9	NSE	625	6	A
10	NSE	15083	6	A
11	NSE	22	6	A
12

_Row\^Col	A	B	C	D	E	F
1	NSE	25	6			A
2	NSE	17388	6			A
3	NSE	404	6			A
4	NSE	422	6	>	116815	A
5	NSE	10604	6			A
6	NSE	438	6			A
7	NSE	10794	6			A
8	NSE	1250	6	>	13595	A
9	NSE	625	6			A
10	NSE	15083	6	>	27335	A
11	NSE	22	6			A
12

Macro used to get the results in the last post above

In support of this post
http://www.excelfox.com/forum/showth...ll=1#post13140
Previous macro
https://www.ozgrid.com/forum/index.p...38#post1234138

Code:

' Old macro ( https://www.ozgrid.com/forum/index.php?thread/1227284-copy-and-paste-by-macro/&postID=1234138#post1234138 ) Sub STEP8() ' http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13126&viewfull=1#post13126 Dim Wb1 As Workbook, Wb2 As Workbook Dim Ws1 As Worksheet, Ws2 As Worksheet Dim rg1 As Range, i As Long, c As Range Set Wb1 = Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") Set Wb2 = Workbooks("AlertTestData.xlsx") ' Workbooks("Alert.csv") ' Workbooks("Alert.txt") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Alert..csv") Set Ws1 = Wb1.Worksheets.Item(1) Set Ws2 = Wb2.Worksheets.Item(1) Set rg1 = Ws1.Cells(1, 1).CurrentRegion With rg1 For i = 2 To rg1.Rows.Count If .Cells(i, 8) > .Cells(i, 4) Then ' if column H of 1.xls is greater than column D of 1.xls If .Cells(i, 9).Value = "" Then ' do nothing Else Set c = Ws2.Columns(2).Find(.Cells(i, 9)) ' match column I of 1.xls with column B of 2.csv If Not c Is Nothing Then 'if match found c.Offset(, 2).Value = "<" ' put this symbol "<" in column D of 2 c.Offset(, 3).Value = .Cells(i, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv End If End If Else ' if column H of 1.xls is lower than column D of 1.xls If .Cells(i, 9).Value = "" Then ' do nothing Else Set c = Ws2.Columns(2).Find(.Cells(i, 9)) ' match column I of 1.xls with column B of 2.csv If Not c Is Nothing Then 'if match found c.Offset(, 2).Value = ">" ' then put this symbol ">" in column D of 2.csv c.Offset(, 3).Value = .Cells(i, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv End If End If End If Next i End With End Sub

New macro ( for http://www.excelfox.com/forum/showth...3144#post13144 )

Code:

Sub STEP8_AE() ' http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13126&viewfull=1#post13126 Rem 1 Worksheets data range info Dim Wb1 As Workbook, Wb2 As Workbook Dim Ws1 As Worksheet, Ws2 As Worksheet Set Wb1 = Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") Set Wb2 = Workbooks("AlertTestData.xlsx") ' Workbooks("Alert.csv") ' Workbooks("Alert.txt") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Alert..csv") Set Ws1 = Wb1.Worksheets.Item(1) Set Ws2 = Wb2.Worksheets.Item(1) Dim Rg1 As Range, RngSrchIn As Range Set Rg1 = Ws1.Cells.Item(1, 1).CurrentRegion Dim Lr2 As Long: Let Lr2 = Ws2.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. ) Set RngSrchIn = Ws2.Range("B1:B" & Lr2 & "") ' Only us as much of Column B as we need to search in for a match Rem 2 Dim Cnt For Cnt = 2 To Rg1.Rows.Count ' For all rows in 1.xls Dim cRng As Range '2a Check for match, BUT DO IT PROPERLY!!! - http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13142&viewfull=1#post13142 Set cRng = RngSrchIn.Find(What:=Ws1.Cells.Item(Cnt, 9), LookIn:=xlValues, Lookat:=xlWhole, searchorder:=xlByRows, Searchdirection:=xlNext, MatchCase:=True) If Not cRng Is Nothing And Not cRng.Value = "" Then If Ws1.Cells(Cnt, 8) > Ws1.Cells(Cnt, 4) Then ' if column H of 1.xls is greater than column D of 1.xls Let cRng.Offset(, 2).Value = "<" ' put this symbol "<" in column D of 2 Let cRng.Offset(, 3).Value = Ws1.Cells(Cnt, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv ElseIf Ws1.Cells(Cnt, 8) < Ws1.Cells(Cnt, 4) Then ' if column H of 1.xls is lower than column D of 1.xls Let cRng.Offset(, 2).Value = ">" ' then put this symbol ">" in column D of 2.csv Let cRng.Offset(, 3).Value = Ws1.Cells(Cnt, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv Else ' column H of 1.xls is equal to column D of 1.xls End If Else ' cRng is nothing so no match was found, or cell was empty ' do nothing End If Next Cnt End Sub ' If .Cells(i, 8) > .Cells(i, 4) Then ' if column H of 1.xls is greater than column D of 1.xls ' If .Cells(i, 9).Value = "" Then ' ' do nothing ' Else ' Set c = Ws2.Columns(2).Find(.Cells(i, 9)) ' match column I of 1.xls with column B of 2.csv ' If Not c Is Nothing Then 'if match found ' c.Offset(, 2).Value = "<" ' put this symbol "<" in column D of 2 ' c.Offset(, 3).Value = .Cells(i, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv ' End If ' End If ' Else ' if column H of 1.xls is lower than column D of 1.xls ' If .Cells(i, 9).Value = "" Then ' ' do nothing ' Else ' Set c = Ws2.Columns(2).Find(.Cells(i, 9)) ' match column I of 1.xls with column B of 2.csv ' If Not c Is Nothing Then 'if match found ' c.Offset(, 2).Value = ">" ' then put this symbol ">" in column D of 2.csv ' c.Offset(, 3).Value = .Cells(i, 11) ' copy paste the data of column K of 1.xls in column E of 2.csv ' End If ' End If ' End If

Macro for this Post
http://www.excelfox.com/forum/showth...ed-from-Sheet1

Code:

Option Explicit Sub testIt() ' http://www.excelfox.com/forum/showthread.php/2463-VBA-to-create-formula-references-and-values-in-Sheet2-that-either-reference-or-are-derived-from-Sheet1 Call Worksheet_SelectionChange(Me.Range("B10")) End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Rem 1 check fo column B single cell selection, if not exit sub If Target.Cells.Count > 1 Or Application.Intersect(Target, Columns("B")) Is Nothing Then Exit Sub Rem 2 second worksheets info Dim Ws2 As Worksheet: Set Ws2 = ThisWorkbook.Worksheets.Item(2) Dim Lr2 As Long: Let Lr2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row Rem 3 insert row - create a new row on "Sheet2" one line above the last used row and fill in the cells as follows: Ws2.Rows("" & Lr2 & ":" & Lr2 & "").Insert shift:=xlDown Rem 4 Create formulas in columns "A" ("Description") & "B" ("Item #") in "Sheet2" that have formulas that references those values from "Sheet1". Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1) Let Ws2.Range("A" & Lr2 & "").Value = "=" & Ws1.Name & "!" & Target.Address(Rowabsolute:=False, columnabsolute:=False) Let Ws2.Range("B" & Lr2 & "").Value = "=" & Ws1.Name & "!" & Target.Offset(0, 1).Address(Rowabsolute:=False, columnabsolute:=False) Rem 5 create a formula in column "E" ("Gross Income") in "Sheet2". Let Ws2.Range("E" & Lr2 & "").Value = "=" & Ws2.Range("C" & Lr2 & "").Address(Rowabsolute:=False, columnabsolute:=False) & "*" & Ws2.Range("D" & Lr2 & "").Address(Rowabsolute:=False, columnabsolute:=False) Rem 6 fill in a value in column "G" ("Sugg. Retail Price") in "Sheet2" from the value in column "F" ("Sugg. Retail Price") of "Sheet1" Let Ws2.Range("G" & Lr2 & "").Value = Ws1.Range("D" & Target.Row & "").Value End Sub

_Row\^Col	A	B	C	D	E	F
1	11	a	Do not delete
2	12	B	Delete this row
3	13	c	Delete this row
4	14	D	Do not delete
5
6				Original Range:-
7				11	a	Do not delete
8				12	B	Delete this row
9				13	c	Delete this row
10				14	D	Do not delete
11

_Row\^Col	A	B	C	D	E	F	G
1
2		Item(1)	Item(2)
3		Item(3)	Item(4)
4		Item(5)	Item(6)
5		Item(7)	Item(8)		Item(1)	Item(2)	Item(3)
6		Item(9)	….etc…		Item(4)	Item(5)	Item(6)
7					Item(7)	Item(8)	Item(9)
8					Item(10)	….etc….
9	Item(1)
10	Item(2)			Item(1)
11	Item(3)			Item(2)
12	Item(4)			Item(3)
13	Item(5)			Item(4)
14	Item(6)			Item(5)
15	…..etc….			Item(6)
16				Item(7)
17				Item(8)
18				Item(9)
19				Item(10)
20				….etc…
21

_Row\^Col	K	L	M	N
2	1090.699
3	147.965
4	264.4785
5	30.2495
6
7
8		5	1090.69	109069
9		4	147.96	14796
10		4	264.47	26447
11		3	30.24	3024
12
13		1090.699
14		147.965
15		264.4785
16		30.2495