Appendix Thread. ( Codes for other Threads, etc.) Event Coding Drpdown Data validation

[DocAElstein]

In support of this Post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12670



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

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12671


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

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12672


' 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

[DocAElstein]

In support of this post.
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12672


Sub DDAllEarlier_Marz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wsdrs As Worksheet: Set Wsdrs = Worksheets("drivers marz 2020") ' C2:E180 F2:H180
Dim Rngdr1 As Range, Rngdr2 As Range '
Set Rngdr1 = Wsdrs.Range("F2:H180"): Set Rngdr2 = Wsdrs.Range("C2:E180") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020
' take each cell in column B range and find it in column D, but find next if the text is already coloured
Dim Rng As Range
For Each Rng In Rngdr2 '----------------------| looking at each cell in the newest range, trying to find it in the original range
If Rng <> "" Then
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim FndRng As Range ' FndRng, if found, is in RngDD2 , looking for value in each cell in RngDD1
Set FndRng = Rngdr1.Find(what:=Rng.Value, After:=Rngdr1.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not have already been found.
Do While Not FndRng Is Nothing ' ===
If FndRng.Interior.ColorIndex = -4142 Then ' case "virgin "white"" text
FndRng.Select
Let FndRng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Rng.Select
Let Rng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Set FndRng = Nothing ' This will force the Loop to end after a succesful match
Else ' The cell text is already colored, so try again
Set FndRng = Wsdrs.Range("F" & FndRng.Row + 1 & ":H180").Find(what:=Rng.Value, After:=Wsdrs.Range("H180"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
End If
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng ' Each Rng In Rngdr2 ---------------|
End Sub

[DocAElstein]

In support of this post…


http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12673




' =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

[DocAElstein]

Test blog post, and function needed for other posts…


http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12673




Title….

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

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

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




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

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





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

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

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








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

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#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.


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

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12675



' 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

[DocAElstein]

Macro for this post solution, ( written by the son of God )
http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12897&viewfull=1#post12897



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

[DocAElstein]

In support of these posts

http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12676
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12677
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12678



' 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

[DocAElstein]

http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12897&viewfull=1#post12897
Test blog

Loop backwards when deleting rows

Important notes in support of this post: http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12897&viewfull=1#post12897

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\ColABCDEFG
111aDo not delete

212BDelete this row

313cDelete this row

414DDo not delete

5

6Original Range:-

711aDo not delete

812BDelete this row

913cDelete this row

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


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\ColABCDEFG
111aDo not delete

213cDelete this row

314DDo not delete

4

5Original Range:-

611aDo not delete

712BDelete this row

813cDelete this row

914DDo 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\ColABCDEFG
111aDo not delete

212BDelete this row

313cDelete this row

414DDo not delete

5

6Original Range:-

711aDo not delete

812BDelete this row

913cDelete this row

1014DDo not delete

11
Worksheet: MySheet

Macro: ( looping backwards )


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\ColABCDEFG
111aDo not delete

214DDo not delete

3

4Original Range:-

511aDo not delete

612BDelete this row

713cDelete this row

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

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2438-replace-the-entire-row

Before

_____ Workbook: sample1.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1014
1030
955.5
998.45
957.4


3NSEADANIPORTSEQ
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

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1014
1030
955.5
998.45
957.4


3NSEADANIPORTSEQ
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 )

ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

NSEACCEQ
1014
1030
955.5
998.45
957.4

NSEADANIPORTSEQ
27.35
27.75
25.65
25.65
25.85


Worksheet: Tabelle2

[DocAElstein]

In support of this Post:
http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste?p=13014&viewfull=1#post13014

Before:

_____ Workbook: sample1.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1000
1030
955.5
998.45
957.4


3NSEADANIENTEQ
27.35
27.75
25.65
25.65
25.85


4NSEADANIPORTSEQ
259
259.6
244
248.2
251.3


5NSEADANIPOWEREQ5, 45, 55, 65, 75, 8


6NSEAMARAJABATEQ
459.8
482.25
445.1
439.35
455.35


7NSEAMBUJACEMEQ7, 47, 57, 67, 77, 8


8NSEAPOLLOHOSPEQ8, 48, 58, 68, 78, 8


9
Worksheet: anything

_____ Workbook: sample2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A

1SYMBOL


2ACC


3ADANIPORTS


4AMARAJABAT


5
Worksheet: anything

run macro:


' 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

1SYMBOL


2ACC
1000
1030
955.5
998.45
957.4


3ADANIPORTS
259
259.6
244
248.2
251.3


4AMARAJABAT
459.8
482.25
445.1
439.35
455.35


5
Worksheet: anything

[DocAElstein]

Macro for this Post
' 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



' 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

[DocAElstein]

In support of this question
https://excelribbon.tips.net/T008884_Condensing_Multiple_Worksheets_Into_One.ht ml


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


2Item(1)Item(2)


3Item(3)Item(4)


4Item(5)Item(6)


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


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


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


8Item(10)….etc….


9Item(1)


10Item(2)Item(1)


11Item(3)Item(2)


12Item(4)Item(3)


13Item(5)Item(4)


14Item(6)Item(5)


15…..etc….Item(6)


16Item(7)


17Item(8)


18Item(9)


19Item(10)


20….etc…


21

[DocAElstein]

test Evaluate range for this post
http://www.excelfox.com/forum/showthread.php/2456-Remove-decimals-by-vba

We can find the position of the . using Instr function https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/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/office/vba/language/reference/user-interface-help/left-function

Then we can remove the . using the Replace function , https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/replace-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
51090.69109069


9
4147.9614796


10
4264.4726447


11
330.243024


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

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

[DocAElstein]

in support of this forum post
http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally?p=13088&viewfull=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.65This nuber is adjusted down


3
148.05
149.9
146.5
146
146.5
22
1.465
147.95This number is not changed


4
265
269.3
265
262.85
267.15
15083
2.6715
264.5This number is adjusted up


5
30.4
30.4
29.8
29.65
29.95
17388
0.2995
30This 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

[DocAElstein]

VBA Solution to above, and answer to this Post
http://www.excelfox.com/forum/showthread.php/2457-change-the-second-number-after-decimal-conditionally?p=13102&viewfull=1#post13102

VBA answer

Put columns in arrays
Row\Col
D

1Open


2
1087


3
148.05


4
265


5
30.4

arrD() =


1087


148.05


265


30.4



Row\Col
H

1LTP


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


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

[DocAElstein]

In support of this Thread
http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba

1.xls

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/showthread.php/2461-copy-and-paste-by-vba?p=13126&viewfull=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

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1182
1193
1151.7
1156.6
1156.6
22
11.566
116815
1168.166


3NSEADANIENTEQ
137.15
140.55
134.1
134.65
134.65
25
1.3465
13595
135.9965


4NSEADANIPORTSEQ
273.95
276.95
269.55
270.65
270.65
15083
2.7065
27335
273.3565


5NSEADANIPOWEREQ
32.3
32.35
30.45
30.65
30.65
17388
0.3065
3095
30.9565


6NSEAMARAJABATEQ
555
575
529.25
532.1
570.1
100
5.321
5374
537.421
Worksheet: 1-Sheet1

[DocAElstein]

From last post
Before
_____ Workbook: Alert.txt ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1NSE
14361
6A


2NSE
25
6A


3NSE
15083
6A


4NSE
17388
6A


5NSE
100
6A


6NSE
22
6A


7
Worksheet: Alert


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.php?thread/1227284-copy-and-paste-by-macro/&postID=1233954#post1233954 )

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

1NSE
14361
6A


2NSE
25
6>
13595A


3NSE
15083
6>
27335A


4NSE
17388
6>
3095A


5NSE
100
6<
5374A


6NSE
22
6>
116815A


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

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13131&viewfull=1#post13131
It is not necessary to have all data to demonstrate the problem!!

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

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

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1182
1193
1151.7
1190.45
1156.6
22
11.566
116815
1168.166


3NSEDABUREQ
499
503.75
494.5
499
499.05
772
4.9905
4941
494.0595


4NSEDISHTVEQ
5.1
5.15
4.75
4.95
4.75
0.0475
475
4.7975


5NSEUBLEQ
921
922.5
863.85
920
880.75
16713
8.8075
88955
889.5575


6NSEUJJIVANEQ
170
173.5
161.6
179.55
164.1
17069
1.641
1657
165.741


7NSEVEDLEQ
76.8
80.25
75.7
77.6
77.95
3063
0.7795
772
77.1705


8NSEVOLTASEQ
500
505
485
508.2
487.15
3718
4.8715
49202.15
492.0215


9NSEZEELEQ
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

1NSE
25
6A


2NSE
3812
6A


3NSE
15083
6A


4NSE
22
6A


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

1NSE
25
6A


2NSE
3812
6>
1466A


3NSE
15083
6A


4NSE
22
6>
116815A


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

1Low Prev CloseLTP


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

3NSE
15083
6


4NSE
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

1Low Prev CloseLTP


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

3NSE
15083
6


4NSE
22
6


5Empty


6

[DocAElstein]

In support of this post
http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13140&viewfull=1#post13140

Explanation of the problem
The error is caused by bad understanding of Range.Find Method ( https://docs.microsoft.com/de-de/office/vba/api/excel.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

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1182
1193
1151.7
1190.45
1156.6
22
11.566
116815
1168.166


3NSEADANIENTEQ
137.15
140.55
134.1
140.5
134.65
25
1.3465
13595
135.9965


4NSEADANIPORTSEQ
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

1NSE
25
6A


2NSE
17388
6A


3NSE
404
6A


4NSE
422
6A


5NSE
10604
6A


6NSE
438
6A


7NSE
10794
6A


8NSE
1250
6A


9NSE
625
6A


10NSE
15083
6A


11NSE
22
6A


12
Worksheet: Alert.


results After
_____ Workbook: AlertTestData.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F

1NSE
25
6A


2NSE
17388
6A


3NSE
404
6A


4NSE
422
6>
116815A


5NSE
10604
6A


6NSE
438
6A


7NSE
10794
6A


8NSE
1250
6>
13595A


9NSE
625
6A


10NSE
15083
6>
27335A


11NSE
22
6A


12
Worksheet: Alert.


Those results come from using this macro here: http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13143&viewfull=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

[DocAElstein]

Macro used to get the results in the last post above

In support of this post
http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13140&viewfull=1#post13140
Previous macro
https://www.ozgrid.com/forum/index.php?thread/1227284-copy-and-paste-by-macro/&postID=1234138#post1234138

' 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

[DocAElstein]

New macro ( for http://www.excelfox.com/forum/showthread.php/2461-copy-and-paste-by-vba?p=13144#post13144 )


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

[DocAElstein]

Macro for this Post
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


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

[DocAElstein]

Notes for this Post
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE

In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv ........_
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1182
1193
1151.7
1190.45
1156.6
22
11.566
116815
1168.166


3NSEADANIENTEQ
137.15
140.55
134.1
140.5
134.65
25
1.3465
13595
135.9965


4NSEADANIPORTSEQ
273.95
276.95
269.55
277.6
270.65
15083
2.7065
27335
273.3565


5NSEADANIPOWEREQ
32.3
32.35
30.45
32.45
30.65
17388
0.3065
3095
30.9565


6NSEAMARRAJAEQ
555
555
529.25
557.85
532.1
100
5.321
5374
537.21


7
Worksheet: 1-Sheet1 3Mai

_____ Workbook: 3.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1NSE
6AGTT


2


3
Worksheet: Sheet1


_..........
suppose 1.xls has data in 5 rows then copy 3.xlsx first row of sheet3 and paste it to 2.csv 5 times

_____ Workbook: 2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1NSE
6AGTT


2NSE
6AGTT


3NSE
6AGTT


4NSE
6AGTT


5NSE
6AGTT


6
Worksheet: 2

[DocAElstein]

macro solution for last post and solution for
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13185&viewfull=1#post13185

In the macro I have done for you , there are two possibilities.
You only need one
You can choose
' 2b)(i) Relative formula references ...

' 2b)(i) Relative formula references ... https://teylyn.com/2017/03/21/dollarsigns/#comment-191
Ws2.Cells.NumberFormat = "General" ' May be needed to prevent formulas coming out as test =[3.xlsx]Sheet1!$A$1
Let rngOut.Value = "='[3.xlsx]" & Ws3.Name & "'!A$1"
Let rngOut.Value = rngOut.Value ' Change Formulas to values
Let rngOut.Value = Evaluate("If({1},SUBSTITUTE(" & rngOut.Address & ", ""0"", """"))") ' https://excelribbon.tips.net/T010741_Removing_Spaces
' Or
'' 2b)(ii) Copy paste
'Dim rngIn As Range
' Set rngIn = Ws3.Range("A1:" & Lc3Ltr & "1")
' rngIn.Copy
' rngOut.PasteSpecial Paste:=xlPasteValues ' understanding Paste across ranges of different size to Copy range : https://excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in?p=10441&viewfull=1#post10441
OR
' 2b)(ii) Copy Paste

' 2b)(i) Relative formula referrences ... https://teylyn.com/2017/03/21/dollarsigns/#comment-191
' Ws2.Cells.NumberFormat = "General" ' May be needed to prevent formulas coming out as test =[3.xlsx]Sheet1!$A$1
' Let rngOut.Value = "='[3.xlsx]" & Ws3.Name & "'!A$1"
' Let rngOut.Value = rngOut.Value ' Change Formulas to values
' Let rngOut.Value = Evaluate("If({1},SUBSTITUTE(" & rngOut.Address & ", ""0"", """"))") ' https://excelribbon.tips.net/T010741_Removing_Spaces
' Or
' 2b)(ii) Copy Paste
Dim rngIn As Range
Set rngIn = Ws3.Range("A1:" & Lc3Ltr & "1")
rngIn.Copy
rngOut.PasteSpecial Paste:=xlPasteValues ' understanding Paste across ranges of different size to Copy range : https://excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in?p=10441&viewfull=1#post10441



Sub Step14() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=34508 (zyxw123) https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13182#post13182
Rem 1 Worksheets info
Dim w1 As Workbook, w2 As Workbook, w3 As Workbook
Set w1 = Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xlsx")
Set w2 = Workbooks("2.csv") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\document\2.csv")
Set w3 = Workbooks("3.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\files\3.xlsx")
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Set Ws1 = w1.Worksheets.Item(1)
Set Ws2 = w2.Worksheets.Item(1)
Set Ws3 = w3.Worksheets.Item(1)
Dim Lc3 As Long, Lenf1 As Long, Lr1 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 Lc3 = Ws3.Cells.Item(1, Ws3.Columns.Count).End(xlToLeft).Column
Dim Lc3Ltr As String
Let Lc3Ltr = CL(Lc3)
Rem 2 ' In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv
Let Lenf1 = Lr1 - 1 ' 1.xls first row has headers so dont count that
' 2a)
Dim rngOut As Range: Set rngOut = Ws2.Range("A1:" & Lc3Ltr & Lenf1 & "")
' 2b)(i) Relative formula referrences ... https://teylyn.com/2017/03/21/dollarsigns/#comment-191
Ws2.Cells.NumberFormat = "General" ' May be needed to prevent formulas coming out as test =[3.xlsx]Sheet1!$A$1
Let rngOut.Value = "='[3.xlsx]" & Ws3.Name & "'!A$1"
Let rngOut.Value = rngOut.Value ' Change Formulas to values
Let rngOut.Value = Evaluate("If({1},SUBSTITUTE(" & rngOut.Address & ", ""0"", """"))") ' https://excelribbon.tips.net/T010741_Removing_Spaces
' Or
' 2b)(ii) Copy Paste
Dim rngIn As Range
Set rngIn = Ws3.Range("A1:" & Lc3Ltr & "1")
rngIn.Copy
rngOut.PasteSpecial Paste:=xlPasteValues ' understanding Paste across ranges of different size to Copy range : https://excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in?p=10441&viewfull=1#post10441

Rem 3
' w1.Close
' w2.Save
' Let Application.DisplayAlerts = False
' w2.Close
' Let Application.DisplayAlerts = True
' w3.Close
'
End Sub


' http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

[DocAElstein]

In support to answer to this Thread
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE

from about here:
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13193&viewfull=1#post13193

Before csv file link https://drive.google.com/open?id=1MF...s6EWCLjkblGxfo
Before csv.jpg : https://imgur.com/NLryZml
2900

After runing macro csv link https://drive.google.com/open?id=1V_...S63idSd5zlDcVX
After csv.JPG : : https://imgur.com/IzaxRrh
2901

Analysing what we have before and after
To get the single string of what is in the file, from here , https://www.homeandlearn.org/open_a_text_file_in_vba.html https://www.homeandlearn.org/write_to_a_text_file.html ,


I use the below macro to analyse the supplied from vixer google drive share file for Before, ( Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) is in next post )

' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13208&viewfull=1#post13208
Sub TestieCSVstringBefore()
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\" & "2 Before.csv" ' From vixer : https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13193&viewfull=1#post13193 Before csv file link https://drive.google.com/file/d/1MFIgUUiH0QPO1oWpDms6EWCLjkblGxfo/view Before csv.jpg : https://imgur.com/NLryZml
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

End Sub


After running the above macro I get this analysis:

vbCr & vbLf

_._________________________________________
I repeat the same for the supplied After file.

' Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) ' ' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string ' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
Sub TestieCSVstringAfter()
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\" & "2.csv" ' From vixer : https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13193&viewfull=1#post13193 After runing macro csv link https://drive.google.com/file/d/1V_85p1O4lV4RvqHw1dS63idSd5zlDcVX/view After csv.JPG : : https://imgur.com/IzaxRrh
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

End Sub

Here is the result

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
vbCr & vbLf
It is a single long string

Here the same again , differently shown, just for clarity. But remember, it is actually a single long string.

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf &
"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf &
"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf &
"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf &
"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf

Or like
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf

[DocAElstein]

Function required for last post


' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string
' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) '
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make Temporary Sheets, if not already there, in Current Active Workbook, for a simple list of all characters, and for pasting the string into worksheet cells
'1a)(i) Full list of characters worksheet
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but iin general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim ws As Worksheet '
Set ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
ws.Activate: ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1a(ii) Worksheet to paste out string into worksheet cells
If Not Evaluate("=ISREF(" & "'" & "StrIn|WtchaGot" & "'!Z78)") Then
Set Wb = ActiveWorkbook
Wb.Worksheets.Add Before:=Wb.Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = ActiveSheet
Ws1.Activate: Ws1.Cells(1, 1).Activate
Let Ws1.Name = "StrIn|WtchaGot"
Else
Set Ws1 = ThisWorkbook.Worksheets("StrIn|WtchaGot")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. ) https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 40)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop============================================== ==========================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
'SirNirios
If Not Cnt = 1 Then ' I am only intersted in next line comparing the character before, and if i did not do this the next line would error if first character was a "normal" character
If Not Cnt = myLenf And (Mid(strIn, Cnt - 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt - 1, 1) Like "[0-9]" Or Mid(strIn, Cnt - 1, 1) Like "[a-z]") Then ' And (Mid(strIn, Cnt + 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt + 1, 1) Like "[0-9]" Or Mid(strIn, Cnt + 1, 1) Like "[a-z]") Then
Let WotchaGot = WotchaGot & "|LinkTwoNormals|"
Else
End If
Else
End If
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' ' 2a)(ii)_2
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & " ' I actuall would write manually in this case like vbCr &
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case vbNewLine
Let WotchaGot = WotchaGot & "vbNewLine & "
Case """" ' This is how to get a single " No one is quite sure how this works. My theory that, is as good as any other, is that syntaxly """" or " """ or """ " are accepted. But in that the """ bit is somewhat strange for VBA. It seems to match the first and Third " together as a valid pair but the other " in the middle of the 3 "s is also syntax OK, and does not error as """ would because of the final 4th " which it syntaxly sees as a valid pair matched simultaneously as it does some similar check on the first and Third as a concluding string pair. All is well except that the second " is captured within a accepted enclosing pair made up of the first and third " At the same time the 4th " is accepted as a final concluding " paired with the second which it is using but at the same time now isolated from.
Let WotchaGot = WotchaGot & """" & """" & """" & """" & " & " ' The reason why "" "" would not work is that at the end of the "" the next empty character signalises the end of a string pair, and only if it saw a " would it keep checking the syntax rules which then lead in the previous case to the situation described above.
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
' 2a)(iii)
Case Else
If AscW(Caracter) < 256 Then
Let WotchaGot = WotchaGot & "Chr(" & AscW(Caracter) & ")" & " & "
Else
Let WotchaGot = WotchaGot & "ChrW(" & AscW(Caracter) & ")" & " & "
End If
'Let CaseElse = Caracter
End Select
End If ' End of the "normal simple character" or not ' -------2a)------Ended-----------
'2b) A 2 column Array for convenience of a list
Let arrWotchaGot(Cnt + 1, 1) = Cnt & " " & Caracter: Let arrWotchaGot(Cnt + 1, 2) = AscW(Caracter) ' +1 for header
Next Cnt ' ========Main Loop============================================== ===================================
'2c) Some tidying up
If WotchaGot <> "" Then
Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " ( 2 spaces one either side of a & )
Let WotchaGot = Replace(WotchaGot, """ & |LinkTwoNormals|""", "", 1, -1, vbBinaryCompare)
' The next bit changes like this "Lapto" & "p" to "Laptop" You might want to leave it out ti speed things up a bit
If Len(WotchaGot) > 5 And (Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[a-z]") And (Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[a-z]") And Mid(WotchaGot, Len(WotchaGot) - 6, 5) = """" & " & " & """" Then
Let WotchaGot = Left$(WotchaGot, Len(WotchaGot) - 7) & Mid(WotchaGot, Len(WotchaGot) - 1, 2) ' Changes like this "Lapto" & "p" to "Laptop"
Else
End If
Else
End If
Rem 3 Output
'3a) String
'3a)(i)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot ' Hit Ctrl+g from the VB Editor to get a copyable version of the entire string
'3a)(ii)
Ws1.Activate: Ws1.Cells.Item(1, 1).Activate
Let Ws1.Range("A1").Value = strIn
Let Ws1.Range("B1").Value = WotchaGot
'3b) List
Dim NxtClm As Long: Let NxtClm = 1 ' In conjunction with next If this prevents the first column beine taken as 0 for an empty worksheet
ws.Activate: ws.Cells.Item(1, 1).Activate
If Not ws.Range("A1").Value = "" Then Let NxtClm = ws.Cells.Item(1, Columns.Count).End(xlToLeft).Column + 1
Let ws.Cells.Item(1, NxtClm).Resize(UBound(arrWotchaGot(), 1), UBound(arrWotchaGot(), 2)).Value = arrWotchaGot()
ws.Cells.Columns.AutoFit
End Sub
'

[DocAElstein]

Next solution attempt for this:
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13219&viewfull=1#post13219

Do not put a code line in the macro to open 2.csv!




Sub Step14_DogShit() ' https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13219&viewfull=1#post13219
Rem 1 Worksheets info
Dim w1 As Workbook, w2 As Workbook, w3 As Workbook
Set w1 = Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xlsx")
' Do Not open 2.csv ' Set w2 = Workbooks("2.csv") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\document\2.csv")
Set w3 = Workbooks("3.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\files\3.xlsx")
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Set Ws1 = w1.Worksheets.Item(1)
' Set Ws2 = w2.Worksheets.Item(1)
Set Ws3 = w3.Worksheets.Item(1)
Dim Lc3 As Long, Lenf1 As Long, Lr1 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 Lc3 = Ws3.Cells.Item(1, Ws3.Columns.Count).End(xlToLeft).Column
' Dim Lc3Ltr As String
' Let Lc3Ltr = CL(Lc3)
Rem 2 ' In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv
Let Lenf1 = Lr1 - 1 ' 1.xls first row has headers so dont count that
' 2a) get range to be put into dog shit files
Dim arrIn() As Variant: Let arrIn() = Ws3.Range("A1:K1").Value
' 2b) make a string fow a row, including a dog shit Tab seperator
Dim cnt
For cnt = 1 To UBound(arrIn(), 2) ' Column count in worksheet 3 row 1
Dim strLine As String
Let strLine = strLine & arrIn(1, cnt) & vbTab
Next cnt
Let strLine = Left(strLine, (Len(strLine) - 1)) ' Take off last Tab
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strLine) ' "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT"
' 2c) repeat string to include (and include line breaks) to make complete string for do shit text files
For cnt = 1 To Lenf1 ' row count of our dog shit text files
Dim strTotalFile As String
Let strTotalFile = strTotalFile & strLine & vbCr & vbLf
Next cnt
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strTotalFile ) ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13218&viewfull=1#post13218

Rem 4 make dogshit files
' 4a) Dog Shit text
Dim Highway1 As Long: Let Highway1 = FreeFile(0) 'range 1 – 255, inclusive - next free
Open ThisWorkbook.Path & "\" & "DogShit.txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, strTotalFile
Close #Highway1
' 4b) 2.csv
Dim Highway2 As Long: Let Highway2 = FreeFile(0) 'range 1 – 255, inclusive - next free
Open ThisWorkbook.Path & "\" & "2.csv" For Append As #Highway2 ' Will be made if not there
Print #Highway2, strTotalFile
Close #Highway2


Rem ....
' w1.Close
' w2.Save
'' Let Application.DisplayAlerts = False
'' w2.Close
'' Let Application.DisplayAlerts = True
' w3.Close
'
End Sub

[DocAElstein]

Some Development results from running macro from last post


"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT"



"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf



Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strLine)

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT"





Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strTotalFile )

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
& "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
& "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
& "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
& "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT"
& vbCr & vbLf

[DocAElstein]

In support of these Post
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13246&viewfull=1#post13246
http://www.eileenslounge.com/viewtopic.php?p=268627#p268627




These are all text Files. The macro in the next post ( https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13248&viewfull=1#post13248 ) will make them
XXXXSeperatedValuesTextFiles.JPG : https://imgur.com/A2IebLK



Comma Seperated values
(Sometimes called English Comma Seperated Values )

zyxw123,jhas,,rider,roger,anjus,sumanjjj

Leonardo,umpsbug,kinjals,,tinamishra,kinjal124,Wig Wam

Share ‘CommaSeperatedValues.txt’ : https://app.box.com/s/qcjpeu0vt875513gqawmtoufeba3xb28
Share ‘CommaSeperatedValues.csv’ : https://app.box.com/s/w2barpwasveltam4lutjwijks0zft0vq


Tab Seperated Values

zyxw123jhasriderrogeranjussumanjjj

Leonardoumpsbugkinjalstinamishrakinjal124WigWam

Share ‘TabSeperatedValues.csv’ : https://app.box.com/s/ukgxcmxj8xhmy0gzvw5269zyjdmun28g
Share ‘TabSeperatedValues.txt’ : https://app.box.com/s/d24blwuejfixh9ofhrg387nbadxjvu15


NMOD Seperated Values

zyxw123NMODjhasNMODNMODriderNMODrogerNMODanjusNMOD sumanjjj

LeonardoNMODumpsbugNMODkinjalsNMODNMODtinamishraNM ODkinjal124NMODWigWam

Share ‘NMODSeperatedValues.csv’ : https://app.box.com/s/ohxqrao160vapx5jozhx7ejc4t70v1wl
Share ‘NMODSeperatedValues.txt’ : https://app.box.com/s/46p14u9rfwvve0s4yv01zyy34f6qhmmz



Semi Colon Seperated Values
(Sometimes called German Comma Seperated values)

zyxw123;jhas;;rider;roger;anjus;sumanjjj

Leonardo;umpsbug;kinjals;;tinamishra;kinjal124;Wig Wam

Share ‘SemiColonSeperatedValues.csv’ : https://app.box.com/s/kvqqfsjaebzj684rw8n0u1v4hqfi3hea
Share ‘SemiColonSeperatedValues.txt’ : https://app.box.com/s/qojzd9ogwgg2d2unh2k8dkvwzdpgh84e



GollyWobbles Seperated Values

zyxw123GollyWobblesjhasGollyWobblesGollyWobblesrid erGollyWobblesrogerGollyWobblesanjusGollyWobblessu manjjj

LeonardoGollyWobblesumpsbugGollyWobbleskinjalsGoll yWobblesGollyWobblestinamishraGollyWobbleskinjal12 4GollyWobblesWigWam

Share ‘GollyWobblesSeperatedValues.txt’ : https://app.box.com/s/d0pktg8fadbkl8nfwnodfyle5766lghx
Share ‘GollyWobblesSeperatedValues.csv’ : https://app.box.com/s/5xbiy0wrc05txaofr7qknpot7cb3qdo3



Excel File With Wrong Extension

_____ Workbook: ExcelFileWithWrongExtension.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1zyxw123jhasriderrogeranjussumanjjj


2Leonardoumpsbugkinjalstinamishrakinjal124fxe632


3
Worksheet: Tabelle1

Share ‘ExcelFileWithWrongExtension.csv’ : https://app.box.com/s/esxlg0ovoux4gk29zxgklwog6zz6b7s1

[DocAElstein]

In support of these Post
http://www.eileenslounge.com/viewtopic.php?f=30&t=34629





These are all text Files. The macro in this post ( https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13248&viewfull=1#post13248 ) will make them
XXXXSeperatedValuesTextFiles.JPG : https://imgur.com/A2IebLK
PipeSeperatedValuesTextFiles.JPG : https://imgur.com/Y9676cg


Comma Seperated values
(Sometimes called English Comma Seperated Values )

zyxw123,jhas,,rider,roger,anjus,sumanjjj

Leonardo,umpsbug,kinjals,,tinamishra,kinjal124,Wig Wam

Share ‘CommaSeperatedValues.txt’ : https://app.box.com/s/qcjpeu0vt875513gqawmtoufeba3xb28
Share ‘CommaSeperatedValues.csv’ : https://app.box.com/s/w2barpwasveltam4lutjwijks0zft0vq


Pipe Seperated Text Files


zyxw123|jhas||rider|roger|anjus|sumanjjj

Leonardo|umpsbug|kinjals||tinamishra|kinjal124|Wig Wam


Share ‘PipeSeperatedValues.txt’ : https://app.box.com/s/47eo2pmeqlmnjj5h9hlxog8ts47nlgj7
Share ‘PipeSeperatedValues.csv’ : https://app.box.com/s/o7zculmorhyys3r9b6hwwuc3wry1mr6p

[DocAElstein]

In support of this Post
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13246&viewfull=1#post13246



Run the macro below, Sub XXXXXSeperatedValuesTextFiles() ,
It will make text files in the same folder as the folder in which the macro is run in.
( The macro is also in the shared File, XXXXXSeperatedValues.xlsm )
XXXXSeperatedValuesTextFiles.JPG : https://imgur.com/A2IebLK

The text files are shown in the last post https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13247&viewfull=1#post13247


Option Explicit
Sub XXXXXSeperatedValuesTextFiles() ' https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13246#post13246
Call Make____SeperatedValuesTextFiles("CommaSeperatedValues", ",") ' make CSV files ( Comma Seperated Values Files )
Call Make____SeperatedValuesTextFiles("TabSeperatedValues", vbTab) ' make Tab Seperated Values Files
Call Make____SeperatedValuesTextFiles("NMODSeperatedValues", "NMOD") ' make NMOD Seperated Values Files
Call Make____SeperatedValuesTextFiles("SemiColonSeperatedValues", ";") ' make ; Seperated Values Files ( sometimes called german Comma seperated files )
Call Make____SeperatedValuesTextFiles("GollyWobblesSeperatedValues", "GollyWobbles") ' make GollyWobbles Seperated Values Files
Call Make____SeperatedValuesTextFiles("PipeSeperatedValues", "|") ' make Pipe Seperated Values Files
End Sub

Sub Make____SeperatedValuesTextFiles(ByVal Filname As String, Seprator As String)
' Make long string for text file
Dim strTotalFile As String
Let strTotalFile = MakeA____SeperatedValuesTextFile(Seprator)
' .txt Text File
Dim Highway1 As Long: Let Highway1 = FreeFile(0) 'range 1 – 255, inclusive - next free
Open ThisWorkbook.Path & "\" & Filname & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, strTotalFile
Close #Highway1

' .csv Text File
Dim Highway2 As Long: Let Highway2 = FreeFile(0) 'range 1 – 255, inclusive - next free
Open ThisWorkbook.Path & "\" & Filname & ".csv" For Append As #Highway2 ' Will be made if not there
Print #Highway2, strTotalFile
Close #Highway2

End Sub
Function MakeA____SeperatedValuesTextFile(ByVal Seprator As String) As String
Rem 1 Rows
Dim AvinashNamesRow1() As Variant, AvinashNamesRow2() As Variant
Let AvinashNamesRow1() = Array("zyxw123", "jhas", "", "rider", "roger", "anjus", "sumanjjj")
Let AvinashNamesRow2() = Array("Leonardo", "umpsbug", "kinjals", "", "tinamishra", "kinjal124", "fxe632")
Rem 2 make single string for text files
Dim strOut As String
Let strOut = Join(AvinashNamesRow1(), Seprator) & vbCr & vbLf & Join(AvinashNamesRow2(), Seprator) & vbCr & vbLf
Let MakeA____SeperatedValuesTextFile = strOut
End Function




Ref
https://excelfox.com/forum/showthread.php/647-Importing-a-csv-File-to-a-range/page3


XXXXXSeperatedValues.xlsm : https://app.box.com/s/jvlu048tkg0rjw7xi4c4r838abw1z7bi

[sandy666]

ADHahdhdh

do ya have : Attention deficit hyperactivity disorder (ADHD) ??? ;)

[DocAElstein]

do ya have : Attention deficit hyperactivity disorder (ADHD) ??? ;)
Probably :)
it is fixer's fault - he is driving me mad!

[sandy666]

easy, easy, this is a patience test %D

[DocAElstein]

It is character building.
Actually, you are good at geussing what he wants...
I will post just once more now in the main Thread , and then go and break some more rocks for relaxation for the rest of the day..
C ya tomorrrow
:)

[DocAElstein]

Another attempt to geuss what fixer is askig for from here:
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13256&viewfull=1#post13256



Sub OpenTxtFiles_ValuesToBeSeperatedIntoExcelCells()
' Comma seperated values text files
Call OpenA____SeperatedValuesTextFile("CommaSeperatedValues.csv", ",")
Call OpenA____SeperatedValuesTextFile("CommaSeperatedValues.txt", ",")
End Sub

Sub OpenA____SeperatedValuesTextFile(ByVal Filname As String, ByVal Seprator As String)
Rem 1 Get text file as long string.
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\" & Filname '
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
Rem 2 Put values in Excel
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Ws1.Cells.ClearContents
'2b) Split Total File text into a 1 Dimensional array into rows
Dim RwTxt() As String: Let RwTxt() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim Clms() As String
Let Clms() = Split(RwTxt(0), Seprator, -1, vbBinaryCompare) ' This will be the first row of data. Here we are doing it just to gat the column count. In the loop below, we will use it for every row, including initially this first row. We need it below to allow us to access each value seperately seperated via the seprator, seprator
Dim HedClmsCnt As Long: Let HedClmsCnt = UBound(Clms) + 1 ' +1 is required , as , by default , a 1Dimensional array from split has first element indicie of 0 , so Ubound will be 1 less than the number of elements
Dim arrOut() As String ' I must make this dynamic, since i must use the TReDim method to size it. This is because the Dim statement will not accept variables or non static values: It omly accepts actual integer hard coded numbers
ReDim arrOut(1 To UBound(RwTxt) + 1, 1 To HedClmsCnt) ' +1 is required , as , by default , a 1Dimensional array from split has first element indicie of 0 , so Ubound will be 1 less than the number of elements
Dim RwCnt As Long
For RwCnt = 0 To UBound(RwTxt)
'2c) Split each row into seperated values
Let Clms() = Split(RwTxt(RwCnt), Seprator, -1, vbBinaryCompare)
Dim ClmCnt As Long
If Not UBound(Clms()) = -1 Then ' This might be the case fo extra rows in the text file with no seperators in s
For ClmCnt = 1 To HedClmsCnt
Let arrOut(RwCnt + 1, ClmCnt) = Clms(ClmCnt - 1)
Next ClmCnt
Else
End If
Next RwCnt
Rem 2d) Put values from text file into first worksheet
Ws1.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
End Sub

[DocAElstein]

Try number 12976436. Education in Text files

In support of this Thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=34629
DF.txt
Text file, DF.txt (https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic) https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Original uploaded DF.txt looked like this (https://imgur.com/PWq9xQC) as seen for example using a Text Editor (https://imgur.com/Fe3NFt8). ( Notepad is just one of many available text editors )
10,18052020,9.23,0015378
20,1018GS2026,GS,IN0020010081,0.00,0.00,10.00,0.00 ,0.00,10.00
20,1025GS2021,GS,IN0020010040,0.00,0.00 ……..etc.
You are using a comma in DF.txt (https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic) to separate the values. Because you are using a comma to separate your values , we sometimes call such a file a comma separated values file., and we often give a comma separated values text file the extension .csv. But you don’t have to. It’s is your choice. Both DF.txt or DF.csv is OK. You can use either for your text file.
You have used DF.txt for your comma separated values text file. That is a bit unusual, but it is OK. Its your choice.


This macro will allow us to examine that text file, ( for simplicity I am using a test file example of just 3 rows )
Sub WotsInDF_Text() ' ' http://www.eileenslounge.com/viewtopic.php?p=268809#p268809 What is in DF.txt : https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13273&viewfull=1#post13273
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\" & "DF_first 3 rows.txt" ' From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile) ' https://excelfox.com/forum/showthread.php/2302-quot-What%e2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11016&viewfull=1#post11016 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11818&viewfull=1#post11818

End Sub


here is the full single string of the text file, shown in two forms:
_ as seen in a text editor
_ in a VBA code line form

10,18052020,9.23,001537820,1018GS2026,GS,IN0020010 081,0.00,0.00,10.00,0.00,0.00,10.0020,1025GS2021,G S,IN0020010040,0.00,0.00,10.00,0.00,0.00,10.00
"10" & Chr(44) & "18052020" & Chr(44) & "9" & "." & "23" & Chr(44) & "0015378" & vbCr & vbLf & "20" & Chr(44) & "1018GS2026" & Chr(44) & "GS" & Chr(44) & "IN0020010081" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & vbCr & vbLf & "20" & Chr(44) & "1025GS2021" & Chr(44) & "GS" & Chr(44) & "IN0020010040" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00"



here the same again, just shown slightly differently for easy of explanation

"10" & Chr(44) & "18052020" & Chr(44) & "9" & "." & "23" & Chr(44) & "0015378" & vbCr & vbLf
& "20" & Chr(44) & "1018GS2026" & Chr(44) & "GS" & Chr(44) & "IN0020010081" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & vbCr & vbLf
& "20" & Chr(44) & "1025GS2021" & Chr(44) & "GS" & Chr(44) & "IN0020010040" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00"

we see the value seperator comma , ( character 44 ) and the line seperator, vbCr & vbLf

In support of this Thread: https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427
Alert 24 Mai..csv Alert 24 MaiDotDotcsv.jpg : https://imgur.com/0HsAOLj

We analyse using the same macro as above, with this changed code line

Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\" & "Alert 24 Mai..csv" ' https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files Share ‘Alert 24 Mai..csv’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt

Here is the results

NSE,236,6,>,431555,A,,,,,GTTNSE,25,6,>,431555,A,,,,,GTTNSE,15083,6,>,431555,A,,,,,GTTNSE,17388,6,>,431555,A,,,,,GTTNSE,100,6,>,431555,A,,,,,GTTNSE,22,6,>,431555,A,,,,,GTT,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,Entire row of row 3 & row 4 both will be deleted after runing the macro,,,,,,

"NSE" & Chr(44) & "236" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "25" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "15083" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "17388" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "100" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "22" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vb
Lf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "Entire" & " " & "row" & " " & "of" & " " & "row" & " " & "3" & " " & "&" & " " & "row" & " " & "4" & " " & "both" & " " & "will" & " " & "be" & " " & "deleted" & " " & "
after" & " " & "runing" & " " & "the" & " " & "macro" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf


Here again adjusted for clarity

"NSE" & Chr(44) & "236" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "25" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "15083" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "17388" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "100" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "22" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "Entire" & " " & "row" & " " & "of" & " " & "row" & " " & "3" & " " & "&" & " " & "row" & " " & "4" & " " & "both" & " " & "will" & " " & "be" & " " & "deleted" & " " & "after" & " " & "runing" & " " & "the" & " " & "macro" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf




.csv text file is using commas , for the value separator, and for the line separate it has the typical convention of vbCr & vbLf

[DocAElstein]

In Support of this forum question
https://eileenslounge.com/viewtopic.php?p=268481#p268481

_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O
P
Q

6
#VALUE!Got missing number in column ECSE equivalentCSE equivalent


7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10









8eileenslounge
1000.00
1000Got one or more missing numbers


9
1eileenslounge1
4.00
4Got missing number in column E


10
1
2eileenslounge2
9.00
9


11
2
3Others
16.00
16


12
3
4eileenslounge
1000.00
1000


13
4
5eileenslounge1
36.00
36


14
5
6eileenslounge2
49.00
49


15
6
7Others
64.00
64


16
7
8


17
8
Worksheet: data

_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O
P
Q

6
=IF(G6="eileenslounge",1000,F7*E8)=IF(F7="","Got one or more missing numbers",IF(E8="","Got missing number in column E",""))CSE equivalentCSE equivalent


7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10









8eileenslounge
=IF(G8="eileenslounge",1000,F9*E10)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))


9
1eileenslounge1
=IF(G9="eileenslounge",1000,F10*E11)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))


10
1
2eileenslounge2
=IF(G10="eileenslounge",1000,F11*E12)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))


11
2
3Others
=IF(G11="eileenslounge",1000,F12*E13)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))


12
3
4eileenslounge
=IF(G12="eileenslounge",1000,F13*E14)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))


13
4
5eileenslounge1
=IF(G13="eileenslounge",1000,F14*E15)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))


14
5
6eileenslounge2
=IF(G14="eileenslounge",1000,F15*E16)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))


15
6
7Others
=IF(G15="eileenslounge",1000,F16*E17)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))


16
7
8


17
8
Worksheet: data

[DocAElstein]

In Support of this forum question
https://eileenslounge.com/viewtopic.php?p=268481#p268481

_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O

5CSE equivalentCSE equivalent


6
=IF(G6="eileenslounge",1000,F7*E8)=IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))


7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10







8eileenslounge
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))


9
1eileenslounge1
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))


10
1
2eileenslounge2
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))


11
2
3Others
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))


12
3
4eileenslounge
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))


13
4
5eileenslounge1
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))


14
5
6eileenslounge2
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))


15
6
7Others
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))


16
7
8


17
8


18
Worksheet: data


_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O

5CSE equivalentCSE equivalent


6
#VALUE!Got missing number in column F


7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10







8eileenslounge
1000Got one or more missing numbers


9
1eileenslounge1
4Got one or more missing numbers


10
1
2eileenslounge2
9


11
2
3Others
16


12
3
4eileenslounge
1000


13
4
5eileenslounge1
36


14
5
6eileenslounge2
49


15
6
7Others
64


16
7
8


17
8


18
Worksheet: data

[DocAElstein]

Macro accomnpanying last post


Sub EvaluateRangeFormulasC() ' https://eileenslounge.com/viewtopic.php?p=268537#p268537
Dim Ws As Worksheet, Rng As Range, Clm As Range, lRow As Long
Const fRow As Long = 6: Const sRow As Long = 8
Set Ws = ThisWorkbook.Worksheets("data")
' Let lRow = Ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Let lRow = Ws.Range("G" & Ws.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. )
On Error Resume Next
Set Rng = Ws.Rows(fRow).SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Rng Is Nothing Then MsgBox "No formulas!": Exit Sub

Let Application.ScreenUpdating = False
For Each Clm In Rng
Dim strEval As String ' ' Formula in column H Formula in column J
Let strEval = Clm.Formula: Debug.Print strEval ' =IF(G6="eileenslounge",1000,F7*E8) =IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
' modifications to make first formula work in CSE / Range Evaluate sort of a way
Let strEval = Replace(strEval, "G6", "G8:G" & lRow & ""): Debug.Print strEval ' =IF(G8:G15="eileenslounge",1000,F7*E8) =IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
Let strEval = Replace(strEval, "F7*E8", "F9:F16*E10:E17" & lRow & ""): Debug.Print strEval ' =IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715) =IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
Debug.Print ' just to make an emty line in the Immediate window
' modifications required for second formula work in CSE / Range Evaluate sort of a way
Let strEval = Replace(strEval, "E7", "E8:E15" & lRow & ""): Debug.Print strEval ' =IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715) =IF(E8:E1515="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
Let strEval = Replace(strEval, "F8", "F8:F15" & lRow & ""): Debug.Print strEval ' =IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715) =IF(E8:E1515="","Got one or more missing numbers",IF(F8:F1515="","Got missing number in column F",""))
Let Clm.Offset(sRow - fRow).Resize(lRow - sRow + 1).Value = Evaluate(strEval)
Debug.Print ' just to make an emty line in the Immediate window
Next Clm

Let Application.ScreenUpdating = True
End Sub

Running the above macro on the test data in uploade file will give these results:

_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O

5CSE equivalentCSE equivalent


6
#VALUE!Got missing number in column F


7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10







8eileenslounge
1000.00Got one or more missing numbers
1000Got one or more missing numbers


9
1eileenslounge1
4.00Got one or more missing numbers
4Got one or more missing numbers


10
1
2eileenslounge2
9.00
9


11
2
3Others
16.00
16


12
3
4eileenslounge
1000.00
1000


13
4
5eileenslounge1
36.00
36


14
5
6eileenslounge2
49.00
49


15
6
7Others
64.00
64


16
7
8


17
8


18
Worksheet: data




When in the VB Editor, after running the macro, you can hit keys Ctrl+g to see the following in the Immediate window. It shows the build up of the formulas in a full run

=IF(G6="eileenslounge",1000,F7*E8)
=IF(G8:G15="eileenslounge",1000,F7*E8)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715)

=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715)

=IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
=IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
=IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))

=IF(E8:E1515="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
=IF(E8:E1515="","Got one or more missing numbers",IF(F8:F1515="","Got missing number in column F",""))

[DocAElstein]

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706


.csv file before
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497
After downloading the
ALERT.xlsx
file at that post , I navigsted to it using Windows file explorer and physically changed it in the explorer window without opening it to
Alert29Apr..csv

Double clicking that gives this
_____ Workbook: Alert29Apr..csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1
22


2
25


3
15083


4
17388


5
Worksheet: ALERT

The string of thet file has 9096 Characters!! : https://pastebin.com/Ptk0f7S8
Share ‘9096Characters29Apr.xls’ : https://app.box.com/s/8g72lokzoil9fe6j645xcg8hej82gcn7

This is how it opens in Notepads
9096Characters29AprTextNotepads.JPG : https://imgur.com/USuCebF
2928
One of the few things I can see of any sense is towards the start is a "[Content_Types].xml" : -
"Content" & "_" & "Types" & Chr(93) & "." & "xml"
[Content_Types].xml

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

30 2

31 [91

32 C67

33 o111

34 n110

35 t116

36 e101

37 n110

38 t116

39 _95

40 T84

41 y121

42 p112

43 e101

44 s115

45 ]93

46 .46

47 x120

48 m109

49 l108

50 32

This sort of macro gets the long file string.

Sub WhatStringIsInAlertDotCSV() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=34497
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\At Eileen\" & "Alert29Apr..csv" ' This would be made if not existing and we would have a zero lenf string
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Dim Lenf As Long: Let Lenf = LOF(FileNum)
TotalFile = Space(Lenf) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile) ' ' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
End Sub



There are no issues with the file format changing or in not getting the required format if this file is opened saved closed etc.. manually or using the below macro.
Further we see that we can change things, and even add worksheets, save and reopen... All changes and any added worksheets are still there!!
We are beginig to see the problem, or rather another twist in the confusion that is Avinash

Sub OpenEileensAlertDotCSV() ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13343&viewfull=1#post13343
Dim PathAndFileName As String
' The following file was uploaded as ALERT.xlsx I dowloaded it and I navigsted to it using Windows file explorer and physically changed it in the explorer window without opening it to Alert29Apr..csv
Let PathAndFileName = ThisWorkbook.Path & "\At Eileen\" & "Alert29Apr..csv"
Dim Wb As Workbook, WbSaveSimp As Workbook, WbSaveComp As Workbook ' Ws1 As Worksheet
Set Wb = Workbooks.Open(PathAndFileName)
Set WbSaveSimp = Wb: Set WbSaveComp = Wb
Wb.Close: Set Wb = Workbooks.Open(PathAndFileName)
Call WhatStringIsInAlertDotCSV
Wb.Save: Wb.Close
Call WhatStringIsInAlertDotCSV
' ' No issues so far



End Sub
We are beginig to see the problem, or rather another twist in the confusion that is Avinash. We do not always have a .csv file!!!!! - I can see this for example if I manually try to open the file that typically "works" for Avinash Trying to open Alert when it is not a csv.JPG : https://imgur.com/sS2vnw02927
( Note: This warning does not appear when opening the file by a macro, such as in the macro above! )
If I try to do a simple Save on such a file either manually or with coding as in the above macro , then ir is done OK. If I attempt a SaveAs then it will want to save it as an Excel File: Wants to SaveAs xlsx file.JPG : https://imgur.com/RAH3E9T 2929

Furthermore , there is not an issue if I SaveAs manually with a Filename of "Alert29Apr..csv" ,
Save Alert with doubledot csv as xlsx Excel File.JPG
But , it will end up as a new file "Alert29Apr..csv.xlsx
There are not issues with SaveAs saving it with coding: These will give us our Excel file masquerading as a .csv file
Wb.SaveAs Filename:=ThisWorkbook.Path & "\At Eileen" & "Alert29Apr..csv"
Wb.SaveAs Filename:=ThisWorkbook.Path & "\At Eileen" & "Alert29AprRemove a dot.csv"
There are no issues in reopening these files in coding, and also manually if the warning, ( about the file not being the type of the extension ) is ignored

[DocAElstein]

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706


Later

[DocAElstein]

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706


Later

[DocAElstein]

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706





VBA To Copy Rows From One Workbook To text csv File, Based On Count In A Different Workbook


Question
I have three files 2 Excel Files,1.xls & 3.xlsx , and a text file, 2.csv
1.xls first row has headers so don't count that
In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that many rows of 3.xlsx first row of sheet3 to 2.csv
suppose 1.xls has data in 5 rows then copy 3.xlsx first row of sheet3 and paste it to 2.csv 5 times
all files are located in a different path
sheet name can be anything

The final result should be a comma separated values text file , 2.csv.
For example, in Notepad, it looks like this:
2csv is a comma seperated text file.JPG : https://imgur.com/FEjKVMs
2935

That is the final result that I want




Answer:

Sub Step14() ' https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13367&viewfull=1#post13367 ' http://www.eileenslounge.com/viewtopic.php?f=30&t=34508 (zyxw123) https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13182#post13182
Rem 1 Worksheets info
Dim w1 As Workbook, w2 As Workbook, w3 As Workbook
Set w1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xlsx")
Set w2 = Workbooks.Open(ThisWorkbook.Path & "\2.csv") ' Workbooks("2.csv") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\document\2.csv")
Set w3 = Workbooks.Open(ThisWorkbook.Path & "\3.xlsx") ' Workbooks("3.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\files\3.xlsx")
Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Set WS1 = w1.Worksheets.Item(1)
Set WS2 = w2.Worksheets.Item(1)
Set WS3 = w3.Worksheets.Item(1)
Dim Lc3 As Long, Lenf1 As Long, Lr1 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 Lc3 = WS3.Cells.Item(1, WS3.Columns.Count).End(xlToLeft).Column
Dim Lc3Ltr As String
Let Lc3Ltr = CL(Lc3)
Rem 2 ' In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv
Let Lenf1 = Lr1 - 1 ' 1.xls first row has headers so dont count that
' 2a)
Dim rngOut As Range: Set rngOut = WS2.Range("A1:" & Lc3Ltr & Lenf1 & "")
'' 2b)(i) Relative formula referrences ... https://teylyn.com/2017/03/21/dollarsigns/#comment-191
' WS2.Cells.NumberFormat = "General" ' May be needed to prevent formulas coming out as test =[3.xlsx]Sheet1!$A$1
' Let rngOut.Value = "='[3.xlsx]" & WS3.Name & "'!A$1"
' Let rngOut.Value = rngOut.Value ' Change Formulas to values
' Let rngOut.Value = Evaluate("If({1},SUBSTITUTE(" & rngOut.Address & ", ""0"", """"))") ' https://excelribbon.tips.net/T010741_Removing_Spaces
' Or
' 2b)(ii) Copy Paste
Dim rngIn As Range
Set rngIn = WS3.Range("A1:" & Lc3Ltr & "1")
rngIn.Copy
rngOut.PasteSpecial Paste:=xlPasteValues ' understanding Paste across ranges of different size to Copy range : https://excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in?p=10441&viewfull=1#post10441

Rem 3
' 3a
w1.Close
w3.Close
' 3b
w2.SaveAs Filename:=ThisWorkbook.Path & "\2.csv", FileFormat:=xlCSV
Let Application.DisplayAlerts = False
w2.Close
Let Application.DisplayAlerts = True

End Sub

[DocAElstein]

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706


Later


My first answer here was almost perfect. https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13185&viewfull=1#post13185
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13184&viewfull=1#post13184

This was your question:
i have three files 1.xls & 2.csv & 3.xlsx
1.xls first row has headers so dont count that
In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv
suppose 1.xls has data in 5 rows then copy 3.xlsx first row of sheet3 and paste it to 2.csv 5 times
all files are located in a different path
sheet name can be anything


You question should have been you question:
VBA To Copy Rows From One Workbook To text csv File, Based On Count In A Different Workbook
I have three files 2 Excel Files,1.xls & 3.xlsx , and a text file, 2.csv
1.xls first row has headers so don’t count that
In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that many rows of 3.xlsx first row of sheet3 to 2.csv
suppose 1.xls has data in 5 rows then copy 3.xlsx first row of sheet3 and paste it to 2.csv 5 times
all files are located in a different path
sheet name can be anything

The final result should be a comma separated values text file , 2.csv.
For example, in Notepad, it looks like this:
2csv is a comma seperated text file.JPG : https://imgur.com/FEjKVMs


That is the final result that I want


Here is the new solution from me : https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13346&viewfull=1#post13346

Only a very small change was required:

' 3b
w2.SaveAs Filename:=ThisWorkbook.Path & "\2.csv", FileFormat:=xlCSV
Let Application.DisplayAlerts = True
w2.Close



Avinash
Read this, and try to understand at least a little of it.
2.csv is a test file. It is not an Excel file.
For example, in Notepad, it looks like this: [/color]
2csv is a comma seperated text file.JPG : https://imgur.com/FEjKVMs


2.csv is a test file. It is not an Excel file.
You can open a .csv file in Excel, and Excel will do its best to display the data in columns

Sometime Excel will do this:

_____ Workbook: 2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1NSE
6AGTT


2NSE
6AGTT


3NSE
6AGTT


4NSE
6AGTT


5NSE
6AGTT


6
Worksheet: 2


Sometimes Excel will do this:

_____ Workbook: 2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1NSE,,6,,,A,,,,,GTT


2NSE,,6,,,A,,,,,GTT


3NSE,,6,,,A,,,,,GTT


4NSE,,6,,,A,,,,,GTT


5NSE,,6,,,A,,,,,GTT


6
Worksheet: 2

[DocAElstein]

https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706


Alert..txt from Avinash : FromAvinashTextFileAlet__txt.JPG : https://imgur.com/HDHgB0z

USA,101010,6,<,12783,A,,,,,GTT,
USA,22,6,<,12783,A,,,,,GTT,
USA,17388,6,<,12783,A,,,,,GTT,
USA,100,6,<,12783,A,,,,,GTT,
USA,25,6,<,12783,A,,,,,GTT,


"USA" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf & "USA" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf & "USA" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf & "USA" & "," & "100" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf & "USA" & "," & "25" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf


"USA" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf & "USA" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf & "USA" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf & "USA" & "," & "100" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf & "USA" & "," & "25" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf
You will see that vbLf is the separator for lines(records)

This is the macro i used to get that infomation:

Sub WhatStringIsInAlertDotDot_txt() ' 9th June 2020 https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\Alert..txt" ' This would be made if not existing and we would have a zero lenf string
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Dim Lenf As Long: Let Lenf = LOF(FileNum)
TotalFile = Space(Lenf) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile) ' 'https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page34#post13699 https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
End Sub





Here is the macro to answer this thread
https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file


' https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file
Sub xlsxTotxt_LineSeperatorvbLf_valuesSeperatorComma()
Rem 1 Workbooks info
Dim Wb1 As Workbook: Set Wb1 = Workbooks("sample2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb1.Worksheets.Item(1)
Dim Lr As Long, Lc As Long
Let Lr = Ws1.Cells.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Let Lc = Ws1.Cells.Item(1, Ws1.Columns.Count).End(xlToLeft).Column
Dim arrIn() As Variant: Let arrIn() = Ws1.Range(Ws1.Range("A1"), Ws1.Cells.Item(Lr, Lc)).Value ' Data range in sample2.xlsx
Rem 2 make text file long string
Dim Rw As Long, Clm As Long '
For Rw = 1 To Lr ' each row in Ws1
For Clm = 1 To Lc ' each column for each row in Ws1
Dim strTotalFile As String
Let strTotalFile = strTotalFile & arrIn(Rw, Clm) & "," ' add a value and a seperator for this line
Next Clm
Let strTotalFile = Left(strTotalFile, Len(strTotalFile) - 1) ' this will take off the last ,
Let strTotalFile = strTotalFile & vbLf ' this adds the line seperator wanted by Avinash - https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13348 - You will see that vbLf is the separator for lines(records)
Next Rw
Let strTotalFile = Left(strTotalFile, Len(strTotalFile) - 1) ' this takes off the last vbLf
Debug.Print strTotalFile
Rem 3 make text file from the total string
Dim FileNum As Long
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\csv Text file Chaos\Alert..txt" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, strTotalFile ' strTotalFile
Close #FileNum

End Sub

[DocAElstein]

( This post is https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13349 )



Some notes related to these posts

https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706
http://www.eileenslounge.com/viewtopic.php?p=269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fetching-data-from-notepad-to-excel.44312/#post-264364




See here ( This post https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13349 )
for typical comparisons of text Files, Excel files, and data files
Text File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13693&viewfull=1#post13693
Excel File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13694&viewfull=1#post13694
Data File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13695&viewfull=1#post13695


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


Excel Files
A

B

C

D

E

F

G

H

I

J

K


1
USA
vbTab
101010
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT



vbCr
&
vbLf




















2
USA
vbTab
22
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT



vbCr
&
vbLf




















3
USA
vbTab
17388
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT



vbCr
&
vbLf




















4
USA
vbTab
100
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT



vbCr
&
vbLf




















5
USA
vbTab
25
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT



vbCr
&
vbLf


















Worksheet: Sheet1

[DocAElstein]

( This post is https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13693&viewfull=1#post13693 )



Some notes related to these posts

https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706
http://www.eileenslounge.com/viewtopic.php?p=269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fetching-data-from-notepad-to-excel.44312/#post-264364






Text Files
























USA
;
101010
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT



LineSeprator























USA
;
22
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT



LineSeprator























USA
;
17388
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT



LineSeprator























USA
;
100
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT



LineSeprator























USA
;
25
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT



LineSeprator






















Note: With Text files we must concern ourselves with the Record/Line(row) separator and the Field(column) Separator: They may vary. We must know about these.

[DocAElstein]

( This post is https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13694&viewfull=1#post13694 )



Some notes related to these posts

https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706
http://www.eileenslounge.com/viewtopic.php?p=269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fetching-data-from-notepad-to-excel.44312/#post-264364









In Excel we do not have to concern ourselves with the row separator used internally by Excel ( vbCr & vbLf ), or the column Separator used internally by Excel ( vbTab ) : Excel does this for us. We do not need to add these when working with Excel Files. Internally, Excel uses those separators to make the cells that we see and work with.


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

Excel FilesABCDEFGHIJK

1USAvbTab101010vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf

2USAvbTab22vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf

3USAvbTab17388vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf

4USAvbTab100vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf

5USAvbTab25vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf
Worksheet: Sheet1

Note: In Excel we do not have to concern ourselves with the row seperator, vbCr & vbLf or the column Seperator, vbTab: Excel does this for us. We do not need to add these when working with Excel Files
We will only see this:

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

Excel FilesABCDEFGHIJKL

1USA1010106<12783AGTT

2USA226<12783AGTT

3USA173886<12783AGTT

4USA1006<12783AGTT

5USA256<12783AGTT

6
Worksheet: Sheet1

[DocAElstein]

( This post is https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13695&viewfull=1#post13695 )



Some notes related to these posts

https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706
http://www.eileenslounge.com/viewtopic.php?p=269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fetching-data-from-notepad-to-excel.44312/#post-264364









Field1
Field2
Field3
Field4
Field5
Field6
Field7
Field8
Field9
Field10
Field11




Data Files
F1
F2
F3
F4
F5
F6
F7
F8
F9
F10
F11


Row1
Line1
Record1
USA
101010
6
<
12783
A




GTT


Row2
Line2
Record2
USA
22
6
<
12783
A




GTT


Row3
Line3
Record3
USA
17388
6
<
12783
A




GTT


Row4
Line4
Record4
USA
100
6
<
12783
A




GTT


Row5
Line5
Record5
USA
25
6
<
12783
A




GTT


Data files are held in computer memory in different forms and retrieved in different ways. Any particular value may be referrenced in many different ways.

[DocAElstein]

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706


Later

[DocAElstein]

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706


Later

[DocAElstein]

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706


Later

[DocAElstein]

In support of this post:
https://excelfox.com/forum/showthread.php/2493-VBA-required-to-delimit-cells-with-Rules-applied-over-it

_____ Workbook: address sheet.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1AddressDoor#Directionstreet nameroadtypestreet name + roadtypeCity Name


2
204 6 AVE NW
204
6AVENW


3
2510 5 AVE N
2510
5AVEN


4
1 CICADA RD
1CICADARD


5
100 annacis Pkwy
100annacisPkwy


6
100 MAIN ST
100MAINST


7
10008 107 ST
10008
107ST


8
1001 110 AVE
1001
110AVE


9
10010 102A AVE NW
10010102A AVENW


10
10115 110 AVE
10115
110AVE


11
102 11 AVE S
102S
11AVE


12
10205 134 AVE NW
10205134 AVENW


13
10235 101 ST NW
10235101 STNW


14
10365 97 ST NW
1036597 STNW


15
105 MARTIN ST
105MARTINST


16
10504 100 AVE
10504
100AVE


17
10600 100 ST
10600
100ST
Worksheet: Sheet1

[DocAElstein]

Some notes in support in answering this question: https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches

If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx and if it matches then copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to sheet 1 of 2.xlsx in the row of the matched value in column A of sheet 1 of 2.xlsx
i have pasted the result in sheet3 of 2.xlsx but the result should be in sheet1(I have pasted the result in sheet3 only for understanding purpose)


Before:

If column J has data in actual file.xlsx then match column B of actual file.xlsx
_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEASHOKLEYEQ
65
65.35
60.55
63.3
63.3
1


3NSEBANKBARODAEQ
62.1
62.95
56.15
56.65
56.65
1


4NSEBELEQ
66.15
66.75
62.4
65.65
65.65
1


5NSEEQUITASEQ
82
82.05
71
73.05
73.05
1


6NSEFEDERALBNKEQ
68
68.45
62.45
63.1
63.1
1


7NSEGAILEQ
85
88.8
79.1
79.95
79.95
1


8NSEIDFCFIRSTBEQ
32.1
32.35
27.2
27.55
27.55
Worksheet: Sheet1

_.................If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx
_____ Workbook: 2 18May.xlsx ( Using Excel 2007 32 bit )
Row\Col
A

1Stock Name


2ACC


3ADANIENT


4ADANIPORTS


5ASHOKLEY


6EQUITAS


7L&TFH


8
Worksheet: Sheet1

If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx and if it matches then copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to sheet 1 of 2.xlsx
_____ Workbook: 2 18May.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1
1
2
3
4
5
6
7
8
9
10
Worksheet: Sheet2

_.......copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to sheet 1 of 2.xlsx
i have pasted the result in sheet3 of 2.xlsx but the result should be in sheet1(I have pasted the result in sheet3 only for understanding purpose)

After:

_____ Workbook: 2 18May.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1Stock Namedatadatadatadatadatadatadatadatadatadatadatada ta


2ACC
100
108
120
128
134
151
6534
30
90
97
103


3ADANIENT
101
109
121
127
135
122
782
40
92
98


4ADANIPORTS
102
110
122
16
137
177
10
50
93
99
104


5ASHOKLEY
1
2
3
4
5
6
7
8
9
10


6EQUITAS
1
2
3
4
5
6
7
8
9
10


7AMBUJACEM
105
117
125
133
140
746
23
80
96
102
109


8
Worksheet: Sheet3

[DocAElstein]

macro for solution to this Thread:
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches

( Remember to include Public Function CL() )


Sub CopyPaste20() ' https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches
Rem 1 Worksheets info
' 2.xlsx
Dim Wb2 As Workbook
Set Wb2 = Workbooks("2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2 ' 2.xlsx sheet1 column A
Dim Ws2 As Worksheet: Set Ws2 = Wb2.Worksheets.Item(2)
Dim Rng22 As Range: Set Rng22 = Ws2.Range("A1").CurrentRegion ' Row to be copied - (only first row)entire row of data from sheet2 of 2.xlsx

' Actual File.xlsx
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Actual File.xlsx")
Set Ws = Wb.Worksheets.Item(1)
Dim Jmax As Long: Let Jmax = Ws.Range("J" & Ws.Rows.Count & "").End(xlUp).Row
Dim arrB() As Variant: Let arrB() = Ws.Range("B1:B" & Jmax & "").Value2 ' Actual File.xlsx sheet1 column B

Rem 2 do it
Dim Cnt ' this is for - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
For Cnt = 2 To Jmax
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrA(Cnt, 1), arrB(), 0) ' - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
If IsError(MtchRes) Then
' no match do nothing
Else ' Cnt is now at the row number of where 2.xlsx sheet1 column A was found in Actual File.xlsx sheet1 column B
Dim Lc1Cnt As Long: Let Lc1Cnt = Ws1.Cells.Item(Cnt, Ws1.Columns.Count).End(xlToLeft).Column
Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").ClearContents ' clear row Cnt of all data before pasting
Rng22.Copy Destination:=Ws1.Range("B" & Cnt & "") ' copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to the row in sheet 1 of 2.xlsx at the row number of the matched value of 2.xlsx sheet1
End If
Next Cnt
End Sub

' http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

[DocAElstein]

Notes for question 2 here
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13379&viewfull=1#post13379
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13387&viewfull=1#post13387


Before is as here ,
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13382&viewfull=1#post13382
, but ignore Sheet2 - no row is to be copied

If column J has data in actual file.xlsx then match column B of actual file.xlsx

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEASHOKLEYEQ
65
65.35
60.55
63.3
63.3
1


3NSEBANKBARODAEQ
62.1
62.95
56.15
56.65
56.65
1


4NSEBELEQ
66.15
66.75
62.4
65.65
65.65
1


5NSEEQUITASEQ
82
82.05
71
73.05
73.05
1


6NSEFEDERALBNKEQ
68
68.45
62.45
63.1
63.1
1


7NSEGAILEQ
85
88.8
79.1
79.95
79.95
1


8NSEIDFCFIRSTBEQ
32.1
32.35
27.2
27.55
27.55


9NSEIOCEQ
93
93.65
87.25
87.9
87.9


10NSEL&TFHEQ
90
91.55
80.5
81.65
81.65


11
Worksheet: Sheet1 (2)

_.................If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx

_____ Workbook: 2 (2).xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1Stock Namedatadatadatadatadatadatadatadatadatadatadatada tadatadata


2ACC
100
108
120
128
134
151
6534
30
90
97
103


3ADANIENT
101
109
121
127
135
122
782
40
92
98


4ADANIPORTS
102
110
122
16
137
177
10
50
93
99
104


5ASHOKLEY
1
2
3
4
5
16
137
177
10
50
93
99
104


6EQUITAS
10
50
93
99
5
102
110
122
9
10
11


7L&TFH
11
12
13
14
15
16
17
18
19
20
21
22
23


8
Worksheet: Sheet1

If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx and if it matches then double the value of that row of 2.xlsx

After

_____ Workbook: 2 (2).xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1Stock Namedatadatadatadatadatadatadatadatadatadatadatada tadatadata


2ACC
100
108
120
128
134
151
6534
30
90
97
103


3ADANIENT
101
109
121
127
135
122
782
40
92
98


4ADANIPORTS
102
110
122
16
137
177
10
50
93
99
104


5ASHOKLEY
2
4
6
8
10
32
274
354
20
100
186
198
208


6EQUITAS
20
100
186
198
10
204
220
244
18
20
22


7L&TFH
22
24
26
28
30
32
34
36
38
40
42
44
46


8
Worksheet: Sheet2

Note: I think your supplied After is wrong! - L&TFH should not be considered from Actual File.xlsx, because J of that row is not 1

[DocAElstein]

Macro for last post


Sub CopyPaste20Q2() ' Question 2 https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches
' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13388&viewfull=1#post13388
Rem 1 Worksheets info
' 2.xlsx
Dim Wb2 As Workbook
Set Wb2 = Workbooks("2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2 ' 2.xlsx sheet1 column A
' Dim Ws2 As Worksheet: Set Ws2 = Wb2.Worksheets.Item(2)
' Dim Rng22 As Range: Set Rng22 = Ws2.Range("A1").CurrentRegion ' Row to be copied - (only first row)entire row of data from sheet2 of 2.xlsx

' Actual File.xlsx
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Actual File.xlsx")
Set Ws = Wb.Worksheets.Item(1)
Dim Jmax As Long: Let Jmax = Ws.Range("J" & Ws.Rows.Count & "").End(xlUp).Row
Dim arrB() As Variant: Let arrB() = Ws.Range("B1:B" & Jmax & "").Value2 ' Actual File.xlsx sheet1 column B

Rem 2 do it
Dim Cnt ' this is for - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
For Cnt = 2 To Jmax
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrA(Cnt, 1), arrB(), 0) ' - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
If IsError(MtchRes) Then
' no match do nothing
Else ' Cnt is now at the row number of where 2.xlsx sheet1 column A was found in Actual File.xlsx sheet1 column B
Dim Lc1Cnt As Long: Let Lc1Cnt = Ws1.Cells.Item(Cnt, Ws1.Columns.Count).End(xlToLeft).Column
' Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").ClearContents ' clear row Cnt of all data before pasting
' Rng22.Copy Destination:=Ws1.Range("B" & Cnt & "") ' copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to the row in sheet 1 of 2.xlsx at the row number of the matched value of 2.xlsx sheet1
Let Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Value = Ws1.Evaluate("=2*" & Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Address & "") ' then double the value of that row of 2.xlsx
End If
Next Cnt
End Sub

[DocAElstein]

Macro for this post:
https://excelfox.com/forum/showthread.php/2495-Conditional-calculation-and-pasting-of-the-data?p=13397&viewfull=1#post13397






Sub ConditionalCalcPaste() ' https://excelfox.com/forum/showthread.php/2495-Conditional-calculation-and-pasting-of-the-data
Rem 1 Worksheets info
'1a) 2.xlsx
Dim Wb2 As Workbook
Set Wb2 = Workbooks("2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2 ' 2.xlsx sheet1 column A
'Dim Ws2 As Worksheet: Set Ws2 = Wb2.Worksheets.Item(2)
'Dim Rng22 As Range: Set Rng22 = Ws2.Range("A1").CurrentRegion ' Row to be copied - (only first row)entire row of data from sheet2 of 2.xlsx

'1b) Actual File.xlsx
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Actual File.xlsx")
Set Ws = Wb.Worksheets.Item(1)
Dim Lr As Long: Let Lr = Ws.Range("A" & Ws.Rows.Count & "").End(xlUp).Row ' Dim Jmax As Long: Let Jmax = Ws.Range("J" & Ws.Rows.Count & "").End(xlUp).Row

Dim rngIn As Range: Set rngIn = Ws.Range("A1:S" & Lr & "")
Dim arrIn() As Variant, arrOut() As Variant: Let arrIn() = rngIn.Value2
Dim arrB() As Variant: Let arrB() = Ws.Range("B1:B" & Lr & "").Value2 ' Ws.Range("B1:B" & Jmax & "").Value2 ' Actual File.xlsx sheet1 column B

'1c ' calculate the total value of column Q of ActualFile.xlsx and if it is Greater than S10 of ActualFile.xlsx then
Dim SomeQ As Double: Let SomeQ = Ws.Evaluate("=SUM(Q2:Q" & Lr & ")") ' total value of column Q of ActualFile.xlsx
Let SomeQ = Application.WorksheetFunction.Round(SomeQ, 2)
Dim S10Val As Double: Let S10Val = arrIn(10, 19) ' S10 of ActualFile.xlsx
If SomeQ > S10Val Then ' total value of column Q of ActualFile.xlsx and if it is Greater than S10 of ActualFile.xlsx then do nothing
' do nothing
ElseIf SomeQ < S10Val Then ' if it is lower than S10 of ActualFile.xlsx then divide S10 of ActualFile.xlsx with the total value of Column Q of ActualFile.xlsx
Dim S10dQ As Double: Let S10dQ = S10Val / SomeQ ' Divide S10 of ActualFile.xlsx with the total value of Column Q of ActualFile.xlsx
Let S10dQ = Int(S10dQ) ' Application.WorksheetFunction.Round(S10dQ, 4)
Dim Cnt ' this is for - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
For Cnt = 2 To Lr1 ' Jmax
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrA(Cnt, 1), arrB(), 0) ' - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
If IsError(MtchRes) Then
' no match do nothing
Else ' Cnt is now at the row number of where 2.xlsx sheet1 column A was found in Actual File.xlsx sheet1 column B
Dim Lc1Cnt As Long: Let Lc1Cnt = Ws1.Cells.Item(Cnt, Ws1.Columns.Count).End(xlToLeft).Column
' Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").ClearContents ' clear row Cnt of all data before pasting
' Rng22.Copy Destination:=Ws1.Range("B" & Cnt & "") ' copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to the row in sheet 1 of 2.xlsx at the row number of the matched value of 2.xlsx sheet1
Let Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Value = Ws1.Evaluate("=" & S10dQ & "*" & Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Address & "") ' Ws1.Evaluate("=2*" & Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Address & "") ' then double the value of that row of 2.xlsx
End If
Next Cnt
Else
' Sum = S10
End If ' SumQ>S10
End Sub




Share 'Actual File.xlsx' : https://app.box.com/s/9dfaq1997whyyj0jq7ew30sixcmq9zpm
Share '2.xlsx' : https://app.box.com/s/ij24a4nmnnvi0h4qr13h49ro05aouatk
Share 'macro.xlsm' : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt

[DocAElstein]

Test ranges used to answer this post:
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13401&viewfull=1#post13401

Before:

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEASHOKLEYEQ
65
65.35
60.55
63.3
63.3
1
1
60
1.055
1.055
54
56.97


3NSEBANKBARODAEQ
62.1
62.95
56.15
56.65
56.65
1
6
60
0.944167
5.665
54
50.985


4NSEBELEQ
66.15
66.75
62.4
65.65
65.65
1
6
60
1.094167
6.565
54
59.085


5NSEEQUITASEQ
82
82.05
71
73.05
73.05
1
1
60
1.2175
1.2175
54
65.745


6NSEFEDERALBNKEQ
68
68.45
62.45
63.1
63.1
1
6
60
1.051667
6.31
54
56.79


7NSEGAILEQ
85
88.8
79.1
79.95
79.95
1
6
60
1.3325
7.995
54
71.955


8NSEIDFCFIRSTBEQ
32.1
32.35
27.2
27.55
27.55
1
60
0.459167
0.459167
54
24.795


9NSEIOCEQ
93
93.65
87.25
87.9
87.9
1
60
1.465
1.465
54
79.11


10NSEL&TFHEQ
90
91.55
80.5
81.65
81.65
6
51
1.60098
9.605882
54
86.45294


11
Worksheet: Sheet1 (2)

_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1Stock Namedatadatadatadatadatadatadatadatadatadatadatada tadatadata


2ACC
100
108
120
128
134
151
6534
30
90
97
103


3ADANIENT
101
109
121
127
135
122
782
40
92
98


4ADANIPORTS
102
110
122
16
137
177
10
50
93
99
104


5ASHOKLEY
1
2
3
4
5
16
137
177


6ANJALIPHARMA
10
50
93
99
5
102
110
122
9
10
11


7SUNTECK
11
12
13
14
15
16
17
18
19
20
21
22
23


8
Worksheet: Sheet1 (5)

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
O
P
Q
R
S

6
6.31
54
56.79


7
7.995
54
71.955 Total Fund Amount
8387.320769


8
0.459167
54
24.795Current Fund Amount
9000


9
1.465
54
79.11Fund Allocated
8000


10
9.605882
54
86.45294Profit Amount
1000


11Sum is
551.8879
Worksheet: Sheet1 (2)

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
Q

2
56.97


3
50.985


4
59.085


5
65.745


6
56.79


7
71.955


8
24.795


9
79.11


10
86.45294


11
=SUM(Q2:Q10)
Worksheet: Sheet1 (2)


In this example sum of column Q is less than Range S10 value so nothing is done

[DocAElstein]

Macro for last post, and to answer this post:
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13401&viewfull=1#post13401



Sub CopyPaste20Q2b() ' https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13401&viewfull=1#post13401
Rem 1 Worksheets info
' 2.xlsx
Dim Wb2 As Workbook
Set Wb2 = Workbooks("2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2 ' 2.xlsx sheet1 column A
'Dim Ws2 As Worksheet: Set Ws2 = Wb2.Worksheets.Item(2)
'Dim Rng22 As Range: Set Rng22 = Ws2.Range("A1").CurrentRegion ' Row to be copied - (only first row)entire row of data from sheet2 of 2.xlsx

' Actual File.xlsx
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Actual File.xlsx")
Set Ws = Wb.Worksheets.Item(1)
Dim Jmax As Long: Let Jmax = Ws.Range("J" & Ws.Rows.Count & "").End(xlUp).Row
Dim arrB() As Variant: Let arrB() = Ws.Range("B1:B" & Jmax & "").Value2 ' Actual File.xlsx sheet1 column B
'1c ' calculate the total value of column Q of ActualFile.xlsx and if it is Greater than S10 of ActualFile.xlsx then
Dim Lr As Long: Let Lr = Ws.Range("A" & Ws.Rows.Count & "").End(xlUp).Row
Dim SomeQ As Double: Let SomeQ = Ws.Evaluate("=SUM(Q2:Q" & Lr & ")") ' total value of column Q of ActualFile.xlsx
Let SomeQ = Application.WorksheetFunction.Round(SomeQ, 2)
Dim S10Val As Double: Let S10Val = Ws.Range("S10").Value ' S10 of ActualFile.xlsx
If SomeQ > S10Val Then ' total value of column Q of ActualFile.xlsx and if it is Greater than S10 of ActualFile.xlsx then this macro should do the process
Rem 2 do it
Dim Cnt ' this is for - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B but only as far as JMax
For Cnt = 2 To Lr1 ' Jmax
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrA(Cnt, 1), arrB(), 0) ' - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
If IsError(MtchRes) Then
' no match do nothing
Else ' Cnt is now at the row number of where 2.xlsx sheet1 column A was found in Actual File.xlsx sheet1 column B
Dim Lc1Cnt As Long: Let Lc1Cnt = Ws1.Cells.Item(Cnt, Ws1.Columns.Count).End(xlToLeft).Column
' Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").ClearContents ' clear row Cnt of all data before pasting
' Rng22.Copy Destination:=Ws1.Range("B" & Cnt & "") ' copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to the row in sheet 1 of 2.xlsx at the row number of the matched value of 2.xlsx sheet1
Let Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Value = Ws1.Evaluate("=2*" & Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Address & "") ' then double the value of that row of 2.xlsx
End If
Next Cnt
Else
' else do nothing
End If
End Sub

[DocAElstein]

Just testing
ignore all this

C:\Users

ror Resume Next
Set WB1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
If Err <> 0 Then

[DocAElstein]

Macro for this Thread post
https://excelfox.com/forum/showthread.php/2499-calculation-by-percentage-and-conditionally-puting-the-data?p=13423&viewfull=1#post13423


Calculate 2% of colum H & column I & considered the greater number between them
column S should be positive, so don’t considere the no. which are negative
& if column S is lower than that 2% of column H or Column I (whichever is greater )then put -1
vba macro will be placed in a seperate file , sheet name can be anything, all files are located in different place
example
the U2 cell will become -1 after runing the macro



Sub CalculationByPercentageAndConditionallyPutingTheDa ta() ' https://excelfox.com/forum/showthread.php/2499-calculation-by-percentage-and-conditionally-puting-the-data?p=13423&viewfull=1#post13423
Rem worksheets info
' ap.xls
Dim Wbap As Workbook
Set Wbap = Workbooks("ap.xls")
Dim Wsap As Worksheet
Set Wsap = Wbap.Worksheets.Item(1)
Dim Lrap As Long: Let Lrap = Wsap.Range("B" & Wsap.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. )
Dim Arrap As Variant: Let Arrap = Wsap.Range("A1:Y" & Lrap & "").Value2
' 1b) Evaluate range H and I at 2% - Calculate 2% of colum H & column I
Dim arrH2pc() As Variant, arrI2pc() As Variant
Let arrH2pc() = Evaluate("=2/100*H2:H" & Lrap & "")
Let arrI2pc() = Evaluate("=2/100*I2:I" & Lrap & "")

Rem 2
Dim arrS() As Variant: Let arrS() = Wsap.Range("S1:S" & Lrap & "").Value2
Dim arrU() As Variant: Let arrU() = Wsap.Range("U1:U" & Lrap & "").Value2
Dim Cnt As Long
For Cnt = 2 To Lrap
If arrS(Cnt, 1) >= 0 Then
Dim BgstHI As Double ' colum H & column I & considered the greater number between them
Let BgstHI = arrH2pc(Cnt - 1, 1) ' Cnt - 1 is because our arrays for the H and I columns start at row 2 , so the indices will be one less than the roe to which they apply . I chose to do this to avoid trying to get 2% of the header , as that would error
If arrH2pc(Cnt - 1, 1) < arrI2pc(Cnt - 1, 1) Then Let BgstHI = arrI2pc(Cnt - 1, 1) ' If I column is largest, use that, otherwise H will be taken NOTE: H will be taken if the H and I columnns are equal
If arrS(Cnt, 1) < BgstHI Then Let arrU(Cnt, 1) = -1
Else ' S < 0
' column S should be positive, so don’t considere the no. which are negative
End If
Next Cnt

Rem 3 paste out
Let Wsap.Range("U1:U" & Lrap & "").Value2 = arrU()
End Sub


arrHISU.JPG : https://imgur.com/uunxENf
2954



Share ‘macro.xlsm’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt
Share ‘ap.xls’ : https://app.box.com/s/pq6nqkfilk2xs5lf19ozcpx081rp47vs

[DocAElstein]

macro for this post http://www.eileenslounge.com/viewtopic.php?p=268809#p268809



' From vixer zyxw1234 Avinash : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic Excel File, https://app.box.com/s/yyzt8ywwpkkn8vxtxumalp7eg3888jnu Sample1.xlsx
Sub TextFileToExcel() ' http://www.eileenslounge.com/viewtopic.php?p=268809#p268809
Rem 1 Workbooks, Worksheets info
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Sample1.xlsx") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1) ' first worksheet
Dim lr As Long: Let lr = Ws.Range("A" & Ws.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. )
Dim NxtRw As Long
If lr = 1 And Ws.Range("A1").Value = "" Then
Let NxtRw = 1 ' If there is no data in the worksheet we want the first row to be the start row
Else
Let NxtRw = lr + 1 ' If there is data in the worksheet, we ant the data to be posted after the last used row
End If
Rem 2 Text file info
' 2a) get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\" & "DF.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' we can now make an array for all the rows, and we know our columns are A-J = 10 columns
Dim arrOut() As String: ReDim arrOut(1 To RwCnt, 1 To 10)

Rem 3 An array is built up by _....
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To UBound(arrClms()) + 1
Let arrOut(Cnt, Clm) = arrClms(Clm - 1)
Next Clm
Next Cnt

Rem 4 Finally the array is pasted to the worksheet at the next free row
Let Ws.Range("A" & NxtRw & "").Resize(RwCnt, 10).Value = arrOut()
End Sub





Share ‘sample1.xlsx’ : https://app.box.com/s/r0tc0hkwoxrqjsqfu4gh7eqyy5jmqlg2
Share ‘macro.xlsm’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt

[DocAElstein]

In support of this Thread https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427

If column H of 1.xls is greater than column D of 1.xls then calculate 1% of column D of 1.xls & add it to column D of 1.xls and compare column D of 1.xls with column I of 1.xls & if column D of 1.xls is greater than column I of 1.xls then see column I and match column I of of 1.xls with column B of Alert..csv & if it matches then delete that entire row of Alert..csv
If column H of 1.xls is lower than column D of 1.xls then calculate 1% of column D of 1.xls & subtract it to column D of 1.xls and compare column D of 1.xls with column I of 1.xls & if column D of 1.xls is lower than column I then see column I of 1.xls and match column I of of 1.xls with column B of Alert..csv & if it matches then delete that entire row of Alert..csv

Excel File:
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP


2NSEACCEQ
1172
1240
1161.6
1227.1
1227.1
22


3NSEADANIENTEQ
138
141.2
136.6
138.1
140
25


4NSEADANIPORTSEQ
315
315
306.55
310.6
312
15083


5NSEADANIPOWEREQ
33.5
34.5
32.85
33
33.2
17388


6NSEAMARAJABATEQ
600
613.5
586.9
592.55
592.55
100


7NSEASIANPAINTEQ
1568.8
1625
1555.4
1617.9
1617.9
236
Worksheet: 1-Sheet1 24Mai

Text File:

NSE,236,6,>,431555,A,,,,,GTT
NSE,25,6,>,431555,A,,,,,GTT
NSE,15083,6,>,431555,A,,,,,GTT
NSE,17388,6,>,431555,A,,,,,GTT
NSE,100,6,>,431555,A,,,,,GTT
NSE,22,6,>,431555,A,,,,,GTT
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,Entire row of row 3 & row 4 both will be deleted after runing the macro,,,,,




Row in 1.xls


2Column H is > column D Column D + 1% is > Column I 22 is matched to last line of data in Text File. So last line in data File should be removed.


3Column H is > column D Column D + 1% is > Column I 25 is matched to second line of data in Text File. So thisline in data File should be removed.


4Column H is < Column D Column D - 1% is < Column I 15083 is matched to third line of Text File. So this line is to be deleted


5Column H is < Column D Column D - 1% is < Column I 17388 is matched to forth line of Text File. So this line is to be deleted


6Column H is < Column D Column D - 1% is not < Column I so no match to be done , nothing more to be done


7Column H is > column D Column D + 1% is > Column I 236 is matched to first line of data in Text File. So first line in data File should be removed.


Text File after

NSE,100,6,>,431555,A,,,,,GTT
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,Entire row of row 3 & row 4 both will be deleted after runing the macro,,,,,

[DocAElstein]

Macro solution for this post: https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427



' https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427

Sub VBARemoveTextFileLineBasedOnExcelFileConditions()
Rem 1 Workbook, Worksheet info ( Excel File )
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("1.xls") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1)
Dim arrWs() As Variant: Let arrWs() = Ws.Range("A1").CurrentRegion.Value2
Dim Lr As Long: Let Lr = UBound(arrWs(), 1)
Rem 2 text File Info, Import into Excel
' 2a) get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\" & "Alert 24 Mai..csv" ' CHANGE TO SUIT From vixer : https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427 Share ‘Alert 24 Mai..csv’ https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' Alert 24 MaiDotDotcsvBefore.JPG : https://imgur.com/jSZV7Bt , https://imgur.com/ckS9Rzq
' 2c) ' we can now make an array for all the rows, and we know our columns are A-K = 11 columns
Dim arrIn() As String: ReDim arrIn(1 To RwCnt, 1 To 11)
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To UBound(arrClms()) + 1
Let arrIn(Cnt, Clm) = arrClms(Clm - 1)
Next Clm
Next Cnt
' arrIn.jpg : https://imgur.com/agGbjHv
' 2d) second column in text file
Dim Clm2() As Variant: Let Clm2() = Application.Index(arrIn(), 0, 2) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Clm2.jpg : https://imgur.com/Z6jYp3V

Rem 3 Do it
Dim IndDel As String: Let IndDel = " " ' for indices to be deleted from rows out array ''_- an extra " " at the beginning : A spacee before means I will always get a corrent check of a number in the string
For Cnt = 2 To Lr ' considering each data row in 1.xls
Dim D1pc As Double ' for calculate 1% of column D of 1.xls
Dim MtchRes As Variant ' for match column I of of 1.xls with second data column of text file Alert..csv Clm2()
If arrWs(Cnt, 8) > arrWs(Cnt, 4) Then ' If column H of 1.xls is greater than column D of 1.xls then
Let D1pc = 1 / 100 * arrWs(Cnt, 4) ' calculate 1% of column D of 1.xls .._
Let arrWs(Cnt, 4) = arrWs(Cnt, 4) + D1pc ' _.. & add it to column D of 1.xls
If arrWs(Cnt, 4) > arrWs(Cnt, 9) Then ' If column D of 1.xls is greater than column I of 1.xls
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
If IsError(MtchRes) Then
' no match do nothing
Else
Let IndDel = IndDel & MtchRes - 1 & " " ' add an indicee of a row to be deleted
End If
Else
' column D of 1.xls is not greater than column I of 1.xls
End If

ElseIf arrWs(Cnt, 8) < arrWs(Cnt, 4) Then ' If column H of 1.xls is lower than column D of 1.xls then
Let D1pc = 1 / 100 * arrWs(Cnt, 4) ' calculate 1% of column D of 1.xls .._
Let arrWs(Cnt, 4) = arrWs(Cnt, 4) - D1pc ' & _.. subtract it to column D of 1.xls
If arrWs(Cnt, 4) < arrWs(Cnt, 9) Then ' If column D of 1.xls is lower than column I of 1.xls
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
If IsError(MtchRes) Then
' no match do nothing
Else
Let IndDel = IndDel & MtchRes - 1 & " " ' add an indicee of a row to be deleted
End If
Else
' column D of 1.xls is not lower than column I of 1.xls
End If
Else
' column H of 1.xls is = column D of 1.xls
End If ' end of column H compare to column D
Next Cnt

Rem 4 remake the text file row array
Dim arrRwsOut() As String ' array for making a new text file
Dim RwsOut As Long ' for row count in modified outpur rows array, arrrwsOut()
Dim RwDelCnt As Long: Let RwDelCnt = (Len(IndDel) - Len(Replace(IndDel, " ", "", 1, -1, vbBinaryCompare))) - 1 ' -1 because of an extra " " at the beginning - ''_- an extra " " at the beginning : A spacee before means I will always get a corrent check of a number in the string
ReDim arrRwsOut(0 To UBound(arrRws()) - RwDelCnt)
For Cnt = 0 To UBound(arrRws())
If InStr(1, IndDel, " " & Cnt & " ", vbBinaryCompare) = 0 Then
Let arrRwsOut(RwsOut) = arrRws(Cnt)
Let RwsOut = RwsOut + 1
Else
' do nothing since we are at a row to be deleted
End If
Next Cnt

Rem 5 remake the text file
'5a) make a new text file string
Dim strTotalFile As String
Let strTotalFile = Join(arrRwsOut(), vbCr & vbLf)
'5b) make new file
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\csv Text file Chaos\" & "Alert 24 Mai Out..csv" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, strTotalFile
Close #FileNum

End Sub








Text File given:
Share ‘Alert 24 Mai..csv’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt

New text file made after running macro:
Share ‘Alert 24 Mai Out..csv’ : https://app.box.com/s/yseazrdyfloij4ktrhy4ejdpzl0cx02e

Share ‘1.xls’ : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk

Share ‘macro.xlsm’ : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p

[DocAElstein]

test asdsdklj




aslkhSLHDSlhdslhfslkhasklh




ASFJALSKJFASLKJFASLKJFASLKFJALKSJFSLKAJ

lSHFLSHFHSLHF

[DocAElstein]

assfhshffhsfskfh

[DocAElstein]

In support of answer for this post.
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470#post13470

Text file supplied Sample2.csv ( Avinash : https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470
sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t )


NSE,101010,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
NSE,22,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
NSE,17388,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
,100,,,,,,,,,,,,,,,,,,,,,,
,25,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,Only for understanding purpose,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,Before runing the macro,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,After runing the macro,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,,100,,,,,,,,,
,,,,,,,,,,,,,,25,,,,,,,,,


Open in/ with Excel: ( Like: this: https://imgur.com/7pAaLVx , https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13440&viewfull=1#post13440 , for example with text editor
OpenSample2_csvManually with Excel.JPG : https://imgur.com/e7CxxpV)
2963

_____ Workbook: sample2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B

1NSE,101010,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,


2NSE,22,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,


3NSE,17388,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,


4,100,,,,,,,,,,,,,,,,,,,,,,


5,25,,,,,,,,,,,,,,,,,,,,,,


6,,,,,,,,,,,,,,,,,,,,,,,


7,,,,,,,,,,,,,,,,,,,,,,,


8,,,,,,,,,,,,,,,,,,,,,,,


9,,,,,,,,,,,,,,,,,,,,,,,


10,,,,,,,,,,,,,,,,,,,,,,,


11,,,,,,,,,,,,,,,,,,,,,,,


12,,,,,,,,,,,,,,,,,,,,,,,


13,,,,,,,,,,,,,,,,,,,,,,,


14,,,,,,,,,,,,,,,,,,,,,,,


15,,,,,,,,,,,,,,,,,,,,,,,


16,,,,,,,,,,,,,Only for understanding purpose,,,,,,,,,,


17,,,,,,,,,,,,,,,,,,,,,,,


18,,,,,,,,,,,,,Before runing the macro,,,,,,,,,,


19,,,,,,,,,,,,,,,,,,,,,,,


20,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT


21,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT


22,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT


23,,,,,,,,,,,,,,,,,,,,,,,


24,,,,,,,,,,,,,,,,,,,,,,,


25,,,,,,,,,,,,,,,,,,,,,,,


26,,,,,,,,,,,,,,,,,,,,,,,


27,,,,,,,,,,,,,After runing the macro,,,,,,,,,,


28,,,,,,,,,,,,,,,,,,,,,,,


29,,,,,,,,,,,,,,,,,,,,,,,


30,,,,,,,,,,,,,,,,,,,,,,,


31,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT


32,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT


33,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT


34,,,,,,,,,,,,,,100,,,,,,,,,


35,,,,,,,,,,,,,,25,,,,,,,,,


36
Worksheet: sample2


Open with Excel VBA:

Sub OpenVBASample2_csv_5June() ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13476&viewfull=1#post13476
' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2.csv" ' CHANGE TO SUIT
End Sub
' see next post : https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13476&viewfull=1#post13476
see next post : https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13476&viewfull=1#post13476

[DocAElstein]

Sub OpenVBASample2_csv_5June() '
' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2.csv" ' CHANGE TO SUIT
End Sub
_____ Workbook: sample2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S
T
U
V
W
X

1NSE
101010
6<
12783AGTT


2NSE
22
6<
12783AGTT


3NSE
17388
6<
12783AGTT


4
100


5
25


6


7


8


9


10


11


12


13


14


15


16Only for understanding purpose


17


18Before runing the macro


19


20NSE
101010
6<
12783AGTT


21NSE
22
6<
12783AGTT


22NSE
17388
6<
12783AGTT


23


24


25


26


27After runing the macro


28


29


30


31NSE
101010
6<
12783AGTT


32NSE
22
6<
12783AGTT


33NSE
17388
6<
12783AGTT


34
100


35
25
Worksheet: sample2


Note : Sometimes Excel manually or Excel VBA will open .csv file and put values across column cells. but also sometimes Excel manually or Excel VBA will open .csv file and put all values and commas in first cell

[DocAElstein]

Sample2After.csv


NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT
,100,,,,,,,,,,
,25,,,,,,,,,,



In Excel ( open manually )
Open Sample2_csv Manually with Excel.JPG : https://imgur.com/9QNhxrA
_____ Workbook: Sample2After.csv ( Using Excel 2007 32 bit )
Row\Col
A
B

1NSE,101010,6,<,12783,A,,,,,GTT


2NSE,22,6,<,12783,A,,,,,GTT


3NSE,17388,6,<,12783,A,,,,,GTT


4,100,,,,,,,,,,


5,25,,,,,,,,,,


6
Worksheet: Sample2After





In Excel VBA

_ Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2After.csv" ' CHANGE TO SUIT

_____ Workbook: Sample2After.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1NSE
101010
6<
12783AGTT


2NSE
22
6<
12783AGTT


3NSE
17388
6<
12783AGTT


4
100


5
25


6
Worksheet: Sample2After



Note : Sometimes Excel manually or Excel VBA will open .csv file and put values across column cells. but also sometimes Excel manually or Excel VBA will open .csv file and put all values and commas in first cell




Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToR wCnt)


"NSE" & Chr(44) & "101010" & Chr(44) & "6" & Chr(44) & Chr(60) & Chr(44) & "12783" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "22" & Chr(44) & "6" & Chr(44) & Chr(60) & Chr(44) & "12783" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "17388" & Chr(44) & "6" & Chr(44) & Chr(60) & Chr(44) & "12783" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & Chr(44) & "100" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & "25" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf

[DocAElstein]

Macro for this post:
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470




' https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470#post13470
Sub VBAAppendDataToTextFileLineBasedOnTheTextFileAndEx celFileConditions()
Rem 1 Workbook, Worksheet info ( Excel File )
Dim Wb As Workbook, Ws As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb = Workbooks("1.xls") ' Workbooks("Sample1.xls") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1)
Dim arrWs() As Variant: Let arrWs() = Ws.Range("A1").CurrentRegion.Value2
Dim Lr As Long: Let Lr = UBound(arrWs(), 1)
Rem 2 text File Info, Import into Excel Array
Dim PathAndFileName As String, TotalFile As String
' Let PathAndFileName = ThisWorkbook.Path & "\" & "Alert 24 Mai..csv" '
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "Sample2.csv" ' "sample2 ef 5 June.csv" ' CHANGE TO SUIT From Avinash : https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470 sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
' 2a)(i) Determine rows (records) wanted, based on ... First column(field) not being empty
Dim RwCnt As Long, TextFileLineIn As String
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Input As #FileNum 'Open Route to data
Line Input #FileNum, TextFileLineIn ' First line
Do While Left(TextFileLineIn, 4) = "NSE," ' For text file lines like NSE,101010,6,<,12783,A,,,,,GTT
Let RwCnt = RwCnt + 1
Line Input #FileNum, TextFileLineIn ' next line in text file
Loop
Close #FileNum
' 2a)(ii) get the text file as a long single string
Let FileNum = FreeFile(1)
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
'Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' Alert 24 MaiDotDotcsvBefore.JPG : https://imgur.com/jSZV7Bt , https://imgur.com/ckS9Rzq
' 2c) ' we can now make an array for all the rows, and we know our columns are A-K = 11 columns
Dim arrIn() As String: ReDim arrIn(1 To RwCnt, 1 To 11)
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data but only those up to Rwcnt
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To 11
'For Clm = 1 To UBound(arrClms()) + 1
Let arrIn(Cnt, Clm) = arrClms(Clm - 1)
Dim TruncRw As String '_-
Let TruncRw = TruncRw & arrIn(Cnt, Clm) & "," '_- The idea of this is a bodge to get rid of a lot of extra ,,,,,,, if we have empty cells being used, as in Avinash original - sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t - https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13475&viewfull=1#post13475
Next Clm
Let arrRws(Cnt - 1) = Left(TruncRw, Len(TruncRw) - 1) '_- take off the last ,
Let TruncRw = ""
Next Cnt
' 2d) Re make text string of just rows to RwCnt
ReDim Preserve arrRws(0 To RwCnt - 1)
Dim TotalFileToRwCnt As String
Let TotalFileToRwCnt = Join(arrRws(), vbCr & vbLf) & vbCr & vbLf ' This is effectively our long string text file and an extra final carriage return and line feed
' 2d) second column in text file, up to RwCnt
Dim Clm2() As Variant: Let Clm2() = Application.Index(arrIn(), 0, 2) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Clm2Sample2csv.JPG : https://imgur.com/DYYAl3z

Rem 3 Do it
For Cnt = 2 To Lr ' considering each data row in Sample1.xls
' ( If column K of sample1.xls is greater than Column D of sample1.xls & Column H of sample1.xls is Greater than column K of sample1.xls ) or ( If column K of sample1.xls is lower than Column D of sample1.xls & Column H of sample1.xls is lower than column K of sample1.xls ) Then
' Condition 1) or Condition 2)
If (arrWs(Cnt, 11) > arrWs(Cnt, 4) And arrWs(Cnt, 8) > arrWs(Cnt, 11)) Or (arrWs(Cnt, 11) < arrWs(Cnt, 4) And arrWs(Cnt, 8) < arrWs(Cnt, 11)) Then
Dim MtchRes As Variant ' for match column I of of Sample1.xls with second data column of text file Sample2.csv Clm2()
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
' Match Column I of sample1.xls with second field values (column B) of sample2.csv
If Not IsError(MtchRes) Then ' if it is there then do nothing
' match obtsained do nothing
Else ' it is not present paste the column I data of sample1.xls to append second field values (column B) of sample2.csv
Let TotalFileToRwCnt = TotalFileToRwCnt & "," & arrWs(Cnt, 9) & ",,,,,,,,,," & vbCr & vbLf ' make the single text string for the output text file
End If

Else
' Neither of the 2 conditions are met so do nothing
End If

Next Cnt

Rem 5 remake the text file
''5a) make a new text file string
'Dim strTotalFile As String
' Let strTotalFile = Join(arrRwsOut(), vbCr & vbLf)
'5b) make new file
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\" & "Sample2After.csv" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, TotalFileToRwCnt ' strTotalFile
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToR wCnt)

'Rem 6 Check File in Excel VBA open
'' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
' Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2After.csv" ' CHANGE TO SUIT
'

End Sub







sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t
Sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
Sample2After.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
vba.xlsm : https://app.box.com/s/juekenyll42z84j6ms7qonzsngnugoyo

[DocAElstein]

Macro for this post
https://excelfox.com/forum/showthread.php/2517-Copy-and-paste-the-data-if-condition-met


Sub VBAAppendDataToExcelFileRowBasedOnTwoExcelFileCond itions2() ' https://excelfox.com/forum/showthread.php/2517-Copy-and-paste-the-data-if-condition-met Previous macro where second file is .csv text file https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13616&viewfull=1#post13616
Rem 1 sample1.xls
Dim Wb1 As Workbook, Ws1 As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb1 = Workbooks("Sample1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Dim arrWs1() As Variant: Let arrWs1() = Ws1.Range("A1").CurrentRegion.Value2
Dim Lr1 As Long: Let Lr1 = UBound(arrWs1(), 1)
Rem 2 sample2.xlsx
Dim Wb2 As Workbook, Ws2 As Worksheet
Set Wb2 = Workbooks("Sample2.xlsx")
Set Ws2 = Wb2.Worksheets.Item(1)
Dim RwCnt2 As Long: Let RwCnt2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row
Dim NxtRw As Long: Let NxtRw = RwCnt2 + 1 ' next free row in sample2.xlsx
' 2d) second column in sample2.xlsx up maximum size of sample1.xls - that will be the biggest size needed
Dim Clm2() As Variant: Let Clm2() = Ws2.Range("B1:B" & Lr1 & "").Value ' Clm2Sample2xlsx.JPG

Rem 3 Do it
Dim Cnt As Long
For Cnt = 2 To Lr1 ' considering each data row in Sample1.xls
' ( If column K of sample1.xls is greater than Column D of sample1.xls & Column H of sample1.xls is Greater than column K of sample1.xls ) or ( If column K of sample1.xls is lower than Column D of sample1.xls & Column H of sample1.xls is lower than column K of sample1.xls ) Then
' Condition 1) or Condition 2)
If (arrWs1(Cnt, 11) > arrWs1(Cnt, 4) And arrWs1(Cnt, 8) > arrWs1(Cnt, 11)) Or (arrWs1(Cnt, 11) < arrWs1(Cnt, 4) And arrWs1(Cnt, 8) < arrWs1(Cnt, 11)) Then
Dim MtchRes As Variant ' for match column I of of Sample1.xls with second data column of Sample2.xls Clm2()
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I of of 1.xls with second column data of sample2.xlsx
' Match Column I of sample1.xls with second column (column B) of sample2.xlsx
If Not IsError(MtchRes) Then ' if it is there then do nothing
' match obtsained do nothing
Else ' it is not present paste the column I data of sample1.xls to second column values (column B) of sample2.xlsx
Let Clm2(NxtRw, 1) = arrWs1(Cnt, 9)
If NxtRw <> Lr1 Then Let NxtRw = NxtRw + 1 ' If we are not already at the maximum possible row in column B, Ws2 , then we need to adjust NxtRw for next possible missing match
End If

Else
' Neither of the 2 conditions are met so do nothing
End If

Next Cnt

Rem Paste out adjusted/ added to Ws2 column B
Ws2.Range("B1:B" & Lr1 & "").Value = Clm2()
End Sub





sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
sample2.xlsx : https://app.box.com/s/np7kbvjydnyiu95pzyrgn76qi1uqg0ma
vba.xlsm : https://app.box.com/s/lf6otsrl42m6vxxvycjo04zidya6pd2m

[DocAElstein]

Macro to answer this Thread
https://excelfox.com/forum/showthread.php/2520-Conditionally-compare-the-data-amp-delete-entire-row






Sub STEP9t() ' https://excelfox.com/forum/showthread.php/2520-Conditionally-compare-the-data-amp-delete-entire-row
Rem 1 Worksheets info
'1_1 sample1.xls
Dim Wb1 As Workbook, Ws1 As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb1 = Workbooks("1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Dim arrWs1() As Variant: Let arrWs1() = Ws1.Range("A1").CurrentRegion.Value2
Dim Lr1 As Long: Let Lr1 = UBound(arrWs1(), 1)
Dim arrS1() As Variant 'Let arrS1() = Ws1.Range("A1").CurrentRegion.Value
Let arrS1() = Ws1.Range("A1:J" & Lr1 & "").Value ' Input data range
'1_2 Alert.xls
Dim Wb2 As Workbook, Ws2 As Worksheet
Set Wb2 = Workbooks("Alert.xls")
Set Ws2 = Wb2.Worksheets.Item(1)
Dim RwCnt2 As Long: Let RwCnt2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row
'1_2d) second column in Alert.xls
Dim Clm2() As Variant: Let Clm2() = Ws2.Range("B1:B" & RwCnt2 & "").Value

Rem 3
Dim Cnt As Long, MtchRes As Variant
For Cnt = UBound(arrS1(), 1) To 2 Step -1 ' "row" count, Cnt
Select Case arrS1(Cnt, 10) ' column I
Case "BUY" 'If column J of 1.xls has buy then
If arrS1(Cnt, 8) < arrS1(Cnt, 4) Then ' column H of 1.xls is not greater than column D of 1.xls
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I data of 1.xls with column B of alert.xls
If IsError(MtchRes) Then
' no match result so do nothing
Else
Ws2.Range("A" & MtchRes & ":K" & MtchRes & "").Delete shift:=xlUp ' delete that entire row of alert.xls
End If:
Else
End If
Case "" ' If column J of 1.xls has a blank cell then
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I data of 1.xls with column B of alert.xls
If IsError(MtchRes) Then
' no match result so do nothing
Else
Ws2.Range("A" & MtchRes & ":K" & MtchRes & "").Delete shift:=xlUp ' delete that entire row of alert.xls
End If
Case "SHORT" 'If column J is SHORT then
If arrS1(Cnt, 8) > arrS1(Cnt, 4) Then ' column H of 1.xls is Greater than than column D
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I data of 1.xls with column B of alert.xls
If IsError(MtchRes) Then
' no match result so do nothing
Else
Ws2.Range("A" & MtchRes & ":K" & MtchRes & "").Delete shift:=xlUp ' delete that entire row of alert.xls
End If
Else
End If
End Select
Next Cnt

End Sub




macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
Alert.xls : https://app.box.com/s/ectstkrcfnuozys9tmdd0qi3tdvyxb3w

[DocAElstein]

Macro for this post:
https://excelfox.com/forum/showthread.php/2556-copy-and-paste-of-data-if-matches





Sub AddColumnJValueInWs1basedOnMatchAndCritzeriaInWs2( ) ' https://excelfox.com/forum/showthread.php/2556-copy-and-paste-of-data-if-matches
Rem 1 Worksheets info
'1_1 sample1.xls
Dim Wb1 As Workbook, Ws1 As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb1 = Workbooks("1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Dim arrWs1() As Variant: Let arrWs1() = Ws1.Range("A1").CurrentRegion.Value2
Dim Lr1 As Long: Let Lr1 = UBound(arrWs1(), 1)
'1_1b) data range
Dim arrS1() As Variant 'Let arrS1() = Ws1.Range("A1").CurrentRegion.Value
Let arrS1() = Ws1.Range("A1:J" & Lr1 & "").Value ' Input data range
'1_2 AlertCodes.xlsx
Dim WbA As Workbook, WsA4 As Worksheet
Set WbA = Workbooks("AlertCodes.xlsx")
Set WsA4 = WbA.Worksheets.Item(4)
Dim RwCnt4 As Long: Let RwCnt4 = WsA4.Range("A" & WsA4.Rows.Count & "").End(xlUp).Row
'1_2b) dataa range
Dim arrWsA4() As Variant: Let arrWsA4() = WsA4.Range("A1:K" & RwCnt4 & "").Value2
'1_2d) second column in Alertcodes.xlsx
Dim ClmB() As Variant: Let ClmB() = WsA4.Range("B1:B" & RwCnt4 & "").Value

Rem 3
Dim Cnt As Long
For Cnt = 2 To Lr1 ' going down "rows" in 1.xls
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrWs1(Cnt, 9), ClmB(), 0) ' match column I of 1.xls with sheet4 of column B of Alertcodes.xlsx
If IsError(MtchRes) Then
' do nothing - no match
Else ' look at symbol in column D, 4th worksheet of AlertCodes.xlsx for that matched row in column D, 4th worksheet of AlertCodes.xlsx
If arrWsA4(MtchRes, 4) = ">" Then ' If symbol is > then
Let arrS1(Cnt, 10) = "SHORT" ' put SHORT in column J of 1.xls for the matched row
ElseIf arrWsA4(MtchRes, 4) = "<" Then ' If symbol < then
Let arrS1(Cnt, 10) = "BUY" ' put BUY in column J of 1.xls for the matched row
Else
End If

End If
Next Cnt

Rem 4 Paste back out arrS1()
Let Ws1.Range("A1:J" & Lr1 & "").Value2 = arrS1()
End Sub




AlertCodes.xlsx : https://app.box.com/s/jwpjjut9wt3ej7dbns3269ftlpdr7xsm
1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
Vba.xlsm : https://app.box.com/s/lf6otsrl42m6vxxvycjo04zidya6pd2m

[DocAElstein]

In support of these posts
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13617&viewfull=1#post13617
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470

sample2BEFORE.csv
NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT

"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf


"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf


sampLE2AFTER.csv
NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT
,100,,,,,,,,,
,25,,,,,,,,,

"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "," & "100" & "," & "," & "," & "," & "," & "," & "," & "," & "," & vbCr & vbLf & "," & "25" & "," & "," & "," & "," & "," & "," & "," & "," & "," & vbCr & vbLf


"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "," & "100" & "," & "," & "," & "," & "," & "," & "," & "," & "," &
vbCr & vbLf & "," & "25" & "," & "," & "," & "," & "," & "," & "," & "," & "," &
vbCr & vbLf




https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13617&viewfull=1#post13617
sampLE2AFTER.csv : https://drive.google.com/file/d/1TyfOWXhZ9Psg7Z4XhngWwzZ3s43YxzwA
sample2BEFORE : https://drive.google.com/file/d/1X2MdidDmJ886I6HwJLvIqNATRC34o5hD


app.box.com
Share ‘sample2BEFORE.csv’ : https://app.box.com/s/d8lu7iatfv6h8spp9eru8asm3h4v4e4p
Share ‘Sample2After.csv’ : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu










Previous files:
sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t
Sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
Sample2After.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
vba.xlsm : https://app.box.com/s/juekenyll42z84j6ms7qonzsngnugoyo

[DocAElstein]

Macro for this post:
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13617&viewfull=1#post13617



Sub VBAAppendDataToTextFileLineBasedOnTheTextFileAndEx celFileConditions2() ' https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13616&viewfull=1#post13616
Rem 1 Workbook, Worksheet info ( Excel File )
Dim Wb As Workbook, Ws As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb = Workbooks("1.xls") ' Workbooks("Sample1.xls") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1)
Dim arrWs() As Variant: Let arrWs() = Ws.Range("A1").CurrentRegion.Value2
Dim LR As Long: Let LR = UBound(arrWs(), 1)
Rem 2 text File Info, Import into Excel Array
Dim PathAndFileName As String, TotalFile As String
' Let PathAndFileName = ThisWorkbook.Path & "\" & "Alert 24 Mai..csv" '
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "sample2BEFORE.csv" ' "sample2_9June.csv" ' "sample2 8June.csv" ' "Sample2.csv" ' "sample2 ef 5 June.csv" ' CHANGE TO SUIT From Avinash : https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470 sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
' 2a)(i) Determine rows (records) wanted, based on ... First column(field) not being empty
Dim RwCnt As Long, TextFileLineIn As String
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Input As #FileNum 'Open Route to data
Line Input #FileNum, TextFileLineIn ' First line
Do While Not EOF(FileNum) = True And Left(TextFileLineIn, 4) = "NSE," ' Left(TextFileLineIn, 4) = "NSE," ' For text file lines like NSE,101010,6,<,12783,A,,,,,GTT that may have extra unwanted lines like in one Avinash uses stupidly for explanations
Let RwCnt = RwCnt + 1 ' for first and subsequent lines given by below. ... but
Line Input #FileNum, TextFileLineIn ' next line in text file
Loop
If EOF(FileNum) = True Then Let RwCnt = RwCnt + 1 ' ... but if the last line I want is EOF, I will not catch it in the loop so must add a 1 here
Close #FileNum
' 2a)(ii) get the text file as a long single string
Let FileNum = FreeFile(1)
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
'Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' Alert 24 MaiDotDotcsvBefore.JPG : https://imgur.com/jSZV7Bt , https://imgur.com/ckS9Rzq
' 2c) ' we can now make an array for all the rows, and we know our columns are A-K = 11 columns
Dim arrIn() As String: ReDim arrIn(1 To RwCnt, 1 To 11)
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data but only those up to Rwcnt
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To 11
'For Clm = 1 To UBound(arrClms()) + 1
Let arrIn(Cnt, Clm) = arrClms(Clm - 1)
Dim TruncRw As String '_-
Let TruncRw = TruncRw & arrIn(Cnt, Clm) & "," '_- The idea of this is a bodge to get rid of a lot of extra ,,,,,,, if we have empty cells being used, as in Avinash original - sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t - https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13475&viewfull=1#post13475
Next Clm
Let arrRws(Cnt - 1) = Left(TruncRw, Len(TruncRw) - 1) '_- take off the last ,
Let TruncRw = "" '_- so this can be used again for next line(row)
Next Cnt
' 2d) Re make text string of just rows to RwCnt
ReDim Preserve arrRws(0 To RwCnt - 1)
Dim TotalFileToRwCnt As String
Let TotalFileToRwCnt = Join(arrRws(), vbCr & vbLf) & vbCr & vbLf ' This is effectively our long string text file and an extra final carriage return and line feed
' 2d) second column in text file, up to RwCnt
Dim Clm2() As Variant: Let Clm2() = Application.Index(arrIn(), 0, 2) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Clm2Sample2csv.JPG : https://imgur.com/DYYAl3z

Rem 3 Do it
For Cnt = 2 To LR ' considering each data row in Sample1.xls
' ( If column K of sample1.xls is greater than Column D of sample1.xls & Column H of sample1.xls is Greater than column K of sample1.xls ) or ( If column K of sample1.xls is lower than Column D of sample1.xls & Column H of sample1.xls is lower than column K of sample1.xls ) Then
' Condition 1) or Condition 2)
If (arrWs(Cnt, 11) > arrWs(Cnt, 4) And arrWs(Cnt, 8) > arrWs(Cnt, 11)) Or (arrWs(Cnt, 11) < arrWs(Cnt, 4) And arrWs(Cnt, 8) < arrWs(Cnt, 11)) Then
Dim MtchRes As Variant ' for match column I of of Sample1.xls with second data column of text file Sample2.csv Clm2()
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
' Match Column I of sample1.xls with second field values (column B) of sample2.csv
If Not IsError(MtchRes) Then ' if it is there then do nothing
' match obtsained do nothing
Else ' it is not present paste the column I data of sample1.xls to append second field values (column B) of sample2.csv
Let TotalFileToRwCnt = TotalFileToRwCnt & "," & arrWs(Cnt, 9) & ",,,,,,,,,," & vbCr & vbLf ' make the single text string for the output text file
End If

Else
' Neither of the 2 conditions are met so do nothing
End If

Next Cnt

Rem 5 remake the text file
''5a) make a new text file string
'Dim strTotalFile As String
' Let strTotalFile = Join(arrRwsOut(), vbCr & vbLf)
'5b) make new file
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\" & "Sample2After.csv" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, TotalFileToRwCnt ' strTotalFile
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToR wCnt)

Rem 6 Check File in Excel VBA open
' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
' Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2After.csv" ' CHANGE TO SUIT
'Dim Wb As Workbook
' Set Wb = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\sample2.csv")
End Sub




Share ‘sample2BEFORE.csv’ : https://app.box.com/s/d8lu7iatfv6h8spp9eru8asm3h4v4e4p
Share ‘Sample2After.csv’ : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
vba.xlsm : https://app.box.com/s/juekenyll42z84j6ms7qonzsngnugoyo
Sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk

[DocAElstein]

Question 1

Solution for this question, ( 2020-05-28 22:13:09 Rajesh Kumar )
https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html



Question: ( Question 1 )
......I have a list of 80 students. I have made 80 sheets, 1 sheet for 1 student. I want to rename these 80 sheets on the basis of the name in the list, so that whenever I update the name list, the corresponding sheet-name changed automatically. I'm a beginner in this field. Please help me.

Solution.
Hello Rajesh
This requirement is fairly easy with VBA

There are 3 macros which I have written for you, and I am returning 2 workbook examples

Macro for your original requirement
Private Sub Worksheet_Change(ByVal Target As Range)
This macro is in both workbooks:
It does this: If you change any of your names in column B of the worksheets, then the name of the corresponding worksheet tab Name will change, as per your main original requirement.

Workbook AddNamesfromListToExistingWorksheets.xlsm
This is the workbook supplied by you. It has initially 80 student names in column B of the first worksheet. It has 80 additional worksheets , as made by you, with the names of 1 2 3 4 5 …. Etc.
This workbook has a macro , Sub ChangeNamesToExistingWorksheets() . This macro replaces those names with the names from the Student name list in column B

Workbook AddWorksheetsNamedFromList.xlsm
This is your original Workbook, with all but the first worksheet deleted. So this only contains one worksheet containing your list of student Names in column B
In this workbook, there is a macro, Sub AddWorksheetsfromListOfNames()
This macro adds worksheets with the student Names



Note: in your supplied data, you had two identical names at row 26 and at row 75, SACHIN KUMAR , so I changed it to SACHIN KUMAR 2 in row 75
( We could handle such cases in coding, automatically, later if you preferred )


Alan



Workbooks:
Share ‘AddNamesfromListToExistingWorksheets.xlsm’ : https://app.box.com/s/2ytj6qrsyaudh3tzgtodls8l05zn1woz
Share ‘AddWorksheetsNamedFromList.xlsm’ : https://app.box.com/s/yljwyk5ykxtjt2qhzvdpwcrft19phx54
For macros, see also post https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13444




Cross posts
https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html ( 2020-05-28 22:13:09 Rajesh Kumar ) https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html
https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/ https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/

[DocAElstein]

Macros for this post ( Question 1 )
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13443


Option Explicit

' https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13443 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13444

Sub RemoveAllButThisWorksheet()
Dim Cnt
For Cnt = ThisWorkbook.Worksheets.Count To 2 Step -1 ' second worksheet counting tab from the left is worksheets item 2
Let Application.DisplayAlerts = False
ThisWorkbook.Worksheets.Item(Cnt).Delete
Let Application.DisplayAlerts = True
Next Cnt
End Sub
Sub ChangeNamesToExistingWorksheets() '
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Name List") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.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. )
Dim arrNmes() As Variant ' The .Value2 property in the next line will return a field of values housed in Variant type Elements, so we need to give the variant type to our array used to capture that array of values
Let arrNmes() = Ws1.Range("B1:B" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 2 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 2 ( column B )
Let Worksheets.Item(Cnt).Name = arrNmes(Cnt, 1)
Next Cnt
Bed: ' error handling code section.
Let Application.EnableEvents = True
End Sub

Sub AddWorksheetsfromListOfNames()
Rem 0
On Error GoTo Bed
Let Application.EnableEvents = False
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Name List") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.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. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("B1:B" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 2 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 2
Worksheets.Add After:=Worksheets.Item(Worksheets.Count)
Let ActiveSheet.Name = arrNmes(Cnt, 1)
Next Cnt

Bed:
Let Application.EnableEvents = True
End Sub
'
'

Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub ' If we have changed more than 1 cell, our code lines below will error, so best do nothing in such a case
Dim Ws1 As Worksheet
Set Ws1 = Me
Dim Lr1 As Long
Let Lr1 = Ws1.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. )

Dim Rng As Range
Set Rng = Ws1.Range("B2:B" & Lr1 & "")
If Not Intersect(Rng, Target) Is Nothing Then ' The Excel VBA Application.Intersect method returns the range where all the given ranges cross, or Nothing if there are no common cells. So, in this example, we would have Nothing if our selection ( which VBA supplies in Target ) , did not cross our names list ' https://docs.microsoft.com/en-us/office/vba/api/excel.application.intersect
Dim Rw As Long
Let Rw = Target.Row
Let ThisWorkbook.Worksheets.Item(Rw).Name = Target.Value ' In the list, each row number corresponds to the item number of our worksheets made from that list
Else
' changed cell was not in Student name list
End If

End Sub






Cross posts
https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html ( 2020-05-28 22:13:09 Rajesh Kumar ) https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html
https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/ https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/

[DocAElstein]

Macro for these posts ( Question 2 )
https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13442&viewfull=1#post13442
https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13448&viewfull=1#post13448


' _1. I want to create 5 tabs (Sheets) on the basis of these 5 names. (Now the workbook will have 6 tabs, including Master Sheet) https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445
Sub AddWorksheetsfromListOfNames2() ' https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445 https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 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. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("A1:A" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 1 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 1 ( Column A )
Worksheets.Add After:=Worksheets.Item(Worksheets.Count)
Let ActiveSheet.Name = arrNmes(Cnt, 1)
Next Cnt

Bed:
Let Application.EnableEvents = True
End Sub ' (Now the workbook will have 6 tabs, including Master Sheet)

Sub AddHypolinkToWorksheet() ' https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 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. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("A1:A" & Lr1 & "").Value2

Rem 2 Add hyperlinks
Ws1.Hyperlinks.Delete
Dim Cnt
For Cnt = 1 To Lr1 ' ='F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\[DynamicWorksheetNamesLinkHideBasedOnCellValue.xlsm]RAHIM'!$A$1
Dim Paf As String: Let Paf = "='" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & arrNmes(Cnt, 1) & "'!$A$1"
' Ws1.Hyperlinks.Add Anchor:=Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:="='" & arrNmes(Cnt, 1) & "'!A1", ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Ws1.Hyperlinks.Add Anchor:=Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:=Paf, ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Next Cnt
Bed: ' error handling code section.
Let Application.EnableEvents = True
End Sub



Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub ' If we have changed more than 1 cell, our code lines below will error, so best do nothing in such a case
Dim Ws1 As Worksheet
Set Ws1 = Me
Dim Lr1 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. )

Dim Rng As Range
Set Rng = Ws1.Range("A1:A" & Lr1 & "")
If Not Intersect(Rng, Target) Is Nothing Then ' The Excel VBA Application.Intersect method returns the range where all the given ranges cross, or Nothing if there are no common cells. So, in this example, we would have Nothing if our selection ( which VBA supplies in Target ) , did not cross our names list ' https://docs.microsoft.com/en-us/office/vba/api/excel.application.intersect
Dim Rw As Long
Let Rw = Target.Row
If Target.Value = "" Then ' 5. If I delete the content of A1 (ANUJ), i.e, if cell A1 is blank, the corresponding sheet "ANUJ" should hide automatically.
ThisWorkbook.Worksheets.Item(Rw + 1).Visible = False
Exit Sub
Else
ThisWorkbook.Worksheets.Item(Rw + 1).Visible = True
Let ThisWorkbook.Worksheets.Item(Rw + 1).Name = Target.Value ' In the list, each row number corresponds to one less than the item number of our worksheets made from that list
End If
Else
' changed cell was not in Student name list
End If

'
Call AddHypolinkToWorksheet
End Sub





Share ‘DynamicWorksheetNamesLinkHideBasedOnCellValu e. : https://app.box.com/s/louq07ga6uth1508e572l7zr9fakont9

[DocAElstein]

Macros for this post
https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456

Add Workseets from names list, for example from :

_____ Workbook: DynamicWorksheetNamesLinkHideBasedOnCellValueC.xls m ( Using Excel 2007 32 bit )
Row\Col
B
C
D

3


4ANUJ


5RITA


6MUKESH


7RAM


8RAHIN


9Anshu


10
Worksheet: Master Sheet


' _1. I want to create tabs (Sheets) on the basis of names. https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456 https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445
Sub AddWorksheetsfromListOfNamesC() ' https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456 https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445 https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count & "").End(xlUp).Row ' 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. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("C4:C" & Lr1 & "").Value2 ' Range("A1:A" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 1 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 1 ( Column A )
Worksheets.Add After:=Worksheets.Item(Worksheets.Count)
Let ActiveSheet.Name = arrNmes(Cnt, 1)
Next Cnt
Worksheets.Item(1).Select
Bed:
Let Application.EnableEvents = True
End Sub '




Add hypelinks to Worksheets


Sub AddHypolinkToWorksheet()
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count & "").End(xlUp).Row ' 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. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("C4:C" & Lr1 & "").Value2 ' Range("A1:A" & Lr1 & "").Value2

Rem 2 Add hyperlinks
Ws1.Hyperlinks.Delete
Dim Cnt
For Cnt = 4 To Lr1 ' ='F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\[DynamicWorksheetNamesLinkHideBasedOnCellValue.xlsm]RAHIM'!$A$1
Dim Paf As String: Let Paf = "='" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & arrNmes(Cnt - 3, 1) & "'!$A$1" ' "='" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & arrNmes(Cnt, 1) & "'!$A$1"
' Ws1.Hyperlinks.Add Anchor:=Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:="='" & arrNmes(Cnt, 1) & "'!A1", ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Ws1.Hyperlinks.Add Anchor:=Ws1.Range("C" & Cnt & ""), Address:="", SubAddress:=Paf, ScreenTip:=arrNmes(Cnt - 3, 1), TextToDisplay:=arrNmes(Cnt - 3, 1) ' Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:=Paf, ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Next Cnt
Bed: ' error handling code section.
Let Application.EnableEvents = True
End Sub
'



Event macros


'
Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456
'If Target.Column = 1 And Not IsArray(Target.Value) Then ' we are in column A , And we selected one cell
If Target.Column = 3 And Not IsArray(Target.Value) Then ' we are in column C , And we selected one cell
Set LRng = Target
Else

End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub ' If we have changed more than 1 cell, our code lines below will error, so best do nothing in such a case
Dim Ws1 As Worksheet
Set Ws1 = Me
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count & "").End(xlUp).Row ' 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. )
If Not LRng Is Nothing And Target.Value = "" And LRng.Row = Lr1 + 1 Then Let Lr1 = Lr1 + 1
Dim Rng As Range
Set Rng = Ws1.Range("C4:C" & Lr1 & "") ' Ws1.Range("A1:A" & Lr1 & "")
If Not Intersect(Rng, Target) Is Nothing Then ' The Excel VBA Application.Intersect method returns the range where all the given ranges cross, or Nothing if there are no common cells. So, in this example, we would have Nothing if our selection ( which VBA supplies in Target ) , did not cross our names list ' https://docs.microsoft.com/en-us/office/vba/api/excel.application.intersect
Dim Rw As Long
Let Rw = Target.Row
If Target.Value = "" Or Target.Value = "-" Then ' 5. If I delete the content of A1 (ANUJ), i.e, if cell A1 is blank, the corresponding sheet "ANUJ" should hide automatically.
Let Application.EnableEvents = False
Let Target.Value = ""
Let Application.EnableEvents = True
' ThisWorkbook.Worksheets.Item(Rw + 1).Visible = False
ThisWorkbook.Worksheets.Item(Rw + 1 - 3).Visible = False
Exit Sub
Else
' ThisWorkbook.Worksheets.Item(Rw + 1).Visible = True
' Let ThisWorkbook.Worksheets.Item(Rw + 1).Name = Target.Value ' In the list, each row number corresponds to one less than the item number of our worksheets made from that list
ThisWorkbook.Worksheets.Item(Rw + 1 - 3).Visible = True
Let ThisWorkbook.Worksheets.Item(Rw + 1 - 3).Name = Target.Value
End If
Else
' changed cell was not in Student name list
End If

'
Call AddHypolinkToWorksheet
End Sub



Top 2 lines of code module

Option Explicit
Dim LRng As Range




File:
DynamicWorksheetNamesLinkHideBasedOnCellValueC.xls m : https://app.box.com/s/alo1fbzx8r41jd81rttghikytqzvm0w9

[DocAElstein]

kkfhhfsfhsah

[DocAElstein]

In suppot of this forum post
https://www.excelforum.com/excel-programming-vba-macros/1317589-conditionally-compare-the-data-and-delete-entire-row.html#post5340103



' Alert 29May excelforum..csv https://www.excelforum.com/excel-programming-vba-macros/1317589-conditionally-compare-the-data-and-delete-entire-row.html
'If column J of 1.xls has buy & column H of 1.xls is not greater than column D of 1.xls
' then match column I data of 1.xls with column B of alert.csv and
' if it matches then delete that entire row of alert.csv
'If column J of 1.xls has a blank cell
' then match column I data of 1.xls with column B of alert.csv and
' if it matches then delete that entire row of alert.csv
'If column J of 1.xls has short & column H of 1.xls is Greater than than column D of 1.xls
' then match column I data of 1.xls with column B of alert.csv and
' if it matches then delete that entire row of alert.csv

' With Sheets(1)
' Lr = .Range("a" & Rows.Count).End(xlUp).Row

' Missed 3 dots.
' With GetObject(fn)
' With .Sheets(1)
' Lr = .Range("a" & .Rows.Count).End(xlUp).Row
Sub OpenAlert29Mayexcelforum__csv()
Workbooks.Open Filename:=ThisWorkbook.Path & "\Alert 29May excelforum..csv"
End Sub

Sub JindonsTesties() ' Conditionally compare the data & delete entire row - https://www.excelforum.com/excel-programming-vba-macros/1317589-conditionally-compare-the-data-and-delete-entire-row.html#post5340103
' PART 1 ================================
Dim LR As Long, e ', fn As String ' , myCSV As String, txt As String, vTemp As Variant, arrTemp() As Variant
Rem 1 Workbooks, Worksheets info
' fn = ThisWorkbook.Path & "\1.xls" '"C:\Users\WolfieeeStyle\Desktop\1.xls"
' myCSV = ThisWorkbook.Path & "\Alert 29May excelforum..csv" ' "C:\Users\WolfieeeStyle\Desktop\Alert..csv"
' If (Dir(fn) = "") + (Dir(myCSV) = "") Then MsgBox "Invalid file Path/Name": Exit Sub
Dim Wb1 As Workbook
Set Wb1 = Workbooks("1.xls") ' CHANGE TO SUIT
' Set Wb1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") ' CHANGE TO SUIT
'With GetObject(fn)
'With .Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = Wb1.Worksheets.Item(1)
Let LR = Ws1.Range("a" & Ws1.Rows.Count).End(xlUp).Row ' 1.xls last row of data
Rem 2 Make 1 Dimensional arrays for values
'2a) If column J of 1.xls has buy & column H of 1.xls is not greater than column D of 1.xls
'Let vTemp = .Evaluate("transpose(if((j2:j" & LR & "=""buy"")*(h2:h" & LR & "<d2:d" & LR & "),i2:i" & LR & "))")
Dim arrTemp() As Variant
Let arrTemp() = Ws1.Evaluate("transpose(if((j2:j" & LR & "=""buy"")*(h2:h" & LR & "<d2:d" & LR & "),i2:i" & LR & "))")
Dim txt As String
For Each e In Filter(arrTemp(), False, 0) ' Filter(arrTemp(), False, 0) is empty
Let txt = txt & " And (Not F2 = " & e & ")"
Next
'2b) If column J of 1.xls has short & column H of 1.xls is Greater than column D of 1.xls
' Let vTemp = .Evaluate("transpose(if((j2:j" & LR & "=""short"")*(h2:h" & LR & ">d2:d" & LR & "),i2:i" & LR & "))")
Let arrTemp() = Ws1.Evaluate("transpose(if((j2:j" & LR & "=""short"")*(h2:h" & LR & ">d2:d" & LR & "),i2:i" & LR & "))")
For Each e In Filter(arrTemp(), False, 0) ' Filter(arrTemp(), False, 0) is {100}
Let txt = txt & " And (Not F2 = " & e & ")"
Next
'2c) If column J of 1.xls has a blank
' Let vTemp = .Evaluate("transpose(if(j2:j" & LR & "="""",i2:i" & LR & "))")
Let arrTemp() = Ws1.Evaluate("transpose(if(j2:j" & LR & "="""",i2:i" & LR & "))")
For Each e In Filter(arrTemp(), False, 0) ' Filter(arrTemp(), False, 0) is {15083, 17388}
Let txt = txt & " And (Not F2 = " & e & ")"
Next
'End With ' final txt is And (Not F2 = 15083) And (Not F2 = 17388) And (Not F2 = 100)
'.Close
'End With
' CreateNew myCSV, Mid$(txt, 5)
' Let txt = Mid$(txt, 6) ' take off the first " AND "

' Part 2 ================================================== =============================
'End Sub
'Sub MyTests_CreateNew()
Rem 3 source text file
'3a) source text file
Dim myCSV As String ' , txt As String
Let myCSV = ThisWorkbook.Path & "\Alert 29May excelforum..csv" ' "C:\Users\WolfieeeStyle\Desktop\Alert..csv"
' Call CreateNew(myCSV, Mid$(txt, 5))
'End Sub
'Private Sub CreateNew(myCSV As String, txt As String)
Dim fn As String ' , cn As Object, rs As Object, x
' 3b Make copy of test file , make temporary file
fn = Left$(myCSV, InStrRev(myCSV, "\")) & "tempComma.csv"
Dim PathAndFileName As String: Let PathAndFileName = fn
FileCopy myCSV, fn ' FileCopy source, destination https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/filecopy-statement

Rem 4 ADODB stuff
'4a)
Dim Cn As Object: Set Cn = CreateObject("ADODB.Connection")
With Cn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Text;HDR=No;"
'.Open Left(fn, InStrRev(fn, "\"))
Dim PathOnly As String: Let PathOnly = Left(fn, InStrRev(fn, "\"))
.Open PathOnly
End With
'4b)
Let txt = Mid$(txt, 6) ' (Not F2 = 15083) And (Not F2 = 17388) And (Not F2 = 100)
Dim Rs As Object: Set Rs = CreateObject("ADODB.Recordset")
Rs.Open "Select * From [tempComma.csv] Where " & txt, Cn, 3
Dim x As String
Let x = Rs.GetString(, , ",", vbCrLf): Debug.Print x

Set Cn = Nothing: Set Rs = Nothing
Rem 5
Kill fn
Rem 6
Open Replace(myCSV, ".csv", "_Filtered.csv") For Output As #1
Print #1, x;
Close #1
End Sub

[DocAElstein]

In suppot of this forum post
https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file
https://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13348


' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string
' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) '
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make Temporary Sheets, if not already there, in Current Active Workbook, for a simple list of all characters, and for pasting the string into worksheet cells
'1a)(i) Full list of characters worksheet
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but in general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim Ws As Worksheet '
Set Ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
Ws.Activate: Ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let Ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set Ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1a(ii) Worksheet to paste out string into worksheet cells
If Not Evaluate("=ISREF(" & "'" & "StrIn|WtchaGot" & "'!Z78)") Then
Set Wb = ActiveWorkbook
Wb.Worksheets.Add After:=Wb.Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = ActiveSheet
Ws1.Activate: Ws1.Cells(1, 1).Activate
Let Ws1.Name = "StrIn|WtchaGot"
Else
Set Ws1 = ThisWorkbook.Worksheets("StrIn|WtchaGot")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. ) https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 40)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop============================================== ==========================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
'SirNirios
If Not Cnt = 1 Then ' I am only intersted in next line comparing the character before, and if i did not do this the next line would error if first character was a "normal" character
If Not Cnt = myLenf And (Mid(strIn, Cnt - 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt - 1, 1) Like "[0-9]" Or Mid(strIn, Cnt - 1, 1) Like "[a-z]") Then ' And (Mid(strIn, Cnt + 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt + 1, 1) Like "[0-9]" Or Mid(strIn, Cnt + 1, 1) Like "[a-z]") Then
Let WotchaGot = WotchaGot & "|LinkTwoNormals|"
Else
End If
Else
End If
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
Case ","
Let WotchaGot = WotchaGot & """" & "," & """" & " & "
Case ";"
Let WotchaGot = WotchaGot & """" & ";" & """" & " & "
Case ":"
Let WotchaGot = WotchaGot & """" & ":" & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' ' 2a)(ii)_2
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & " ' I actuall would write manually in this case like vbCr &
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case vbNewLine
Let WotchaGot = WotchaGot & "vbNewLine & "
Case """" ' This is how to get a single " No one is quite sure how this works. My theory that, is as good as any other, is that syntaxly """" or " """ or """ " are accepted. But in that the """ bit is somewhat strange for VBA. It seems to match the first and Third " together as a valid pair but the other " in the middle of the 3 "s is also syntax OK, and does not error as """ would because of the final 4th " which it syntaxly sees as a valid pair matched simultaneously as it does some similar check on the first and Third as a concluding string pair. All is well except that the second " is captured within a accepted enclosing pair made up of the first and third " At the same time the 4th " is accepted as a final concluding " paired with the second which it is using but at the same time now isolated from.
Let WotchaGot = WotchaGot & """" & """" & """" & """" & " & " ' The reason why "" "" would not work is that at the end of the "" the next empty character signalises the end of a string pair, and only if it saw a " would it keep checking the syntax rules which then lead in the previous case to the situation described above.
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
' 2a)(iii)
Case Else
If AscW(Caracter) < 256 Then
Let WotchaGot = WotchaGot & "Chr(" & AscW(Caracter) & ")" & " & "
Else
Let WotchaGot = WotchaGot & "ChrW(" & AscW(Caracter) & ")" & " & "
End If
'Let CaseElse = Caracter
End Select
End If ' End of the "normal simple character" or not ' -------2a)------Ended-----------
'2b) A 2 column Array for convenience of a list
Let arrWotchaGot(Cnt + 1, 1) = Cnt & " " & Caracter: Let arrWotchaGot(Cnt + 1, 2) = AscW(Caracter) ' +1 for header
Next Cnt ' ========Main Loop============================================== ===================================
'2c) Some tidying up
If WotchaGot <> "" Then
Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " ( 2 spaces one either side of a & )
Let WotchaGot = Replace(WotchaGot, """ & |LinkTwoNormals|""", "", 1, -1, vbBinaryCompare)
' The next bit changes like this "Lapto" & "p" to "Laptop" You might want to leave it out ti speed things up a bit
If Len(WotchaGot) > 5 And (Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[a-z]") And (Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[a-z]") And Mid(WotchaGot, Len(WotchaGot) - 6, 5) = """" & " & " & """" Then
Let WotchaGot = Left$(WotchaGot, Len(WotchaGot) - 7) & Mid(WotchaGot, Len(WotchaGot) - 1, 2) ' Changes like this "Lapto" & "p" to "Laptop"
Else
End If
Else
End If
Rem 3 Output
'3a) String
'3a)(i)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot ' Hit Ctrl+g from the VB Editor to get a copyable version of the entire string
'3a)(ii)
Ws1.Activate: Ws1.Cells.Item(1, 1).Activate
Let Ws1.Range("A1").Value = strIn
Let Ws1.Range("B1").Value = WotchaGot
'3b) List
Dim NxtClm As Long: Let NxtClm = 1 ' In conjunction with next If this prevents the first column beine taken as 0 for an empty worksheet
Ws.Activate: Ws.Cells.Item(1, 1).Activate
If Not Ws.Range("A1").Value = "" Then Let NxtClm = Ws.Cells.Item(1, Columns.Count).End(xlToLeft).Column + 1
Let Ws.Cells.Item(1, NxtClm).Resize(UBound(arrWotchaGot(), 1), UBound(arrWotchaGot(), 2)).Value = arrWotchaGot()
Ws.Cells.Columns.AutoFit
End Sub
'

[DocAElstein]

lKSHFLhlhfl

[DocAElstein]

lKSHFLhlhfl

[DocAElstein]

lKSHFLhlhfl

[DocAElstein]

So my solution, which I will give in the next post will solve this problem, which is your problem shortened.

_____ Workbook: Autofill.xlsx ( Using Excel 2007 32 bit )
Row\Col
B
C
D
E
F
G

2
S. No.
Alpha Code
Sex
Category
Area



3
1







4
2







5
3





Worksheet: Sheet1
Case1
If I paste or enter A in cell C3, then, automatically put the value…
BOY in cell D3, GEN in cell E3 and URBAN in cell F3
Similarly,
If I paste or enter B in cell C3, then, automatically put the value…
BOY in cell D3, OBC in cell E3 and URBAN in cell F3
Similarly,
As shown in REFERENCE CHART)
the corresponding value should filled in the corresponding cells automatically
Now,
Similarly,
same condition is applied to cell C4, C5, C6 and so on
that is,
If I paste or enter A in cell C4, then, automatically put the value…
BOY in cell D4, GEN in cell E4 and URBAN in cell F4

_____ Workbook: Autofill.xlsx ( Using Excel 2007 32 bit )
Row\Col
R
S
T
U
V
W

1
REFERENCE CHART







2
S. No.
Alpha Code
Sex
Category
Area



3
1
A
BOY
GEN
URBAN



4
2
B
BOY
OBC
URBAN



5
3
C
BOY
SC
URBAN



6
4
D
BOY
ST
URBAN



7
5
E
GIRL
GEN
URBAN

Worksheet: Sheet1

Case2
If I paste or enter BOY in cell D3, GEN in cell E3 and URBAN in cell F3
then, automatically put the value A in cell C3
Similarly,
If I paste or enter BOY in cell D3, OBC in cell E3 and URBAN in cell F3
then, automatically put the value B in cell C3

[DocAElstein]

post to get link for later use...

test


“Moderator” Notice

**I am Banning you to prevent you making any more postings here of the type you have been making here and elsewhere under hundreds of different user names at many of the English speaking Excel and Office help forums for the last couple of years.

The type of post that you have been posting suggest that
_ You may be one person or a !!team of many people working at something organised like a Call Centre.
( !! Sometime when you have been “caught” cross posting, you did not know yourself where you cross posted, and asked to be told. ( Or you maybe only wanted to admit to those where you got “caught”) )
_ You have almost no understanding of the English language
_ You may not have a computer and may have no access to Excel
_ You have no interest in Excel or Excel VBA
_ You have almost no knowledge or interest in any of the questions that you are asking
_ You may be simply offering a service of posting other peoples questions and supplying them with any answers you get.
_ You may be part of the development of a question asking and Replying Bot

_ In some cases, something extremely simple to understand, has been explained to you very many times, in great detail , even graphically, such that even a small mentally handicapped child could understand it and remember it. Despite this, you continually ask exactly that same question over and over again: If you are part of a team interested in only posting questions and taking the answer, then you are very badly organised,
Or
There is no real intelligence behind what is producing your questions and posts
_ One of the things you consistently do after receiving a macro is to delete all explanations, explaining 'comments and all files associated, and indeed it appears as if you try to remove almost all record of the coding and the question and answer. This further encourages the posting of the same or similar questions over and over again.

Whatever you are attempting to do, it appears to be extremely, almost insanely, inefficient ,
compared to
a single person with a computer and Excel, and a minimum of basic Excel VBA knowledge trying to achieve the same.

The main reason for the ban is
Whatever you are attempting to do, it is requiring 10-100 times more time than is typically required of helpers at a forum. All indications are that what you are doing will fail to achieve anything, and is therefore a total waste of everyone’s time. At excelfox, the current small number of helpers have only a limited amount of time, but even if we had more members, excelfox would not be the place for you## Some of the major forums may be a good place for you to post.

These are some suggestions, from me, on how you should continue
_ If you intend to continue, regardless of any of my previous suggestions, in postings of the type as you have done in the past, then you should think about making some changes to your wording, introduce some new canned replies, possibly organise a new set of similar questions and post at the major forums, such as mrexcel.com, excelforum.com, ozgrid.com
_ If you wish to make a career out of posting questions and getting answers without having any real intentions of thinking about anything, then excelfox is not the forum for you to post in. Most of the smaller forums are not the place for you. The larger forums may be able to accommodate you, if you give at least some thought to making it not quite so obvious: Your distinguishing characteristic is that you have been making it much more obvious than others doing the same, do: Many people do the such. At least half the traffic at such forums originates from such. I have passed many people on to such forums and they are making a successful career based on passing on the work done for them by helpers at the major forums. Such is actually encouraged, all be it , not openly, at the major forums.
_ If you have not understood most of this Moderator Notice , then your first priority should be to improve on your English. Indeed, your apparent understanding and ability in communicating in English suggests that you will achieve nothing whatsoever and fail completely in anything at all involving communicating in English.

_ If you are, as you sometimes told me via PM, actively working on an important personal problem requiring VBA , then you are doing it totally wrongly: You have been on the project already for at least two years and have a mixed up set of codings produced by many different people. Some work . Some don’t. You have not the slightest idea or understanding of any of the codings. You will never be able to use them to any effect. If , on the other hand, you had a computer, with Excel, and spent a few weeks learning VBA, and then carefully studied all the macros that you have been given, then you would be able to answer most of your further questions, and would have at least a chance of being able to use the codings effectively:-
1 Month learn VBA and 1 month getting answers, partly alone, partly with help from forums = Finished Success
2+ Years posting the same and similar questions and just taking the answers = Never Ending Fail
_ It is unlikely that the macros you have that work will ever be very efficient and will likely be slower than anyone else’s: They will certainly not be the best possible. Giving you better coding has proved to be impossible: It is not possible to pass on better codings because of the ridiculously inefficient way that you are organising whatever it is that you are doing: The person receiving and passing on the coding needs to understand the English language and to understand some basic coding and to understand how to use such better coding. We have tried this a few times, but it proved always completely impossible to do. One example of this is the issue of text files: Because you are mostly dealing with values, the use of text files is almost certainly beneficial and in some cases the only efficient way to proceed. You have completely missed the point on this: You have repeated much work to try to avoid using text files. The problem was, and will never be, the issue of text files themselves. The issue is your total inability or unwillingness to understand anything at all about them.


##The main purpose of the question section of excelfox is approximately the following:
_1. Promote and improve the understanding of Excel and Excel VBA.
_2. Help people who get stuck on a problem and/or help people who are unsure how to proceed in solving a problem using Excel and Excel VBA.

Your objectives??
I do not know what the true reason is behind your postings. I can’t believe anything you say is your purpose, since you have lied and contradicted yourself in the past. The only thing we know 100% for sure is that your posting types are not for any of the purposes for which the question section of excelfox is intended.
You have had the benefit of the doubt given to you now very many times. You have had lots of chances.
You may be able to continue at some of the major forums, where some people are happy to continue to spend time to answer similar questions from the same source.
I do not think you will get any more replies to the types of postings you have been making at excelfox or at any other of the smaller English speaking Forums. You are wasting your time making any such posts from now on.
**I am Banning you, not as any form of punishment, but purely as in the past , it has proven to be the only way to prevent you wasting yours and other peoples time with your postings.
I do wish you luck and success with what ever it is you are attempting to do. But you should not be doing it at excelfox.
If you are attempting the personal project that you have told me about via PM, then you are going about it in completely the wrong way.
If you are trying to make a career of posting other people’s questions and getting answers for them, then you should post mostly at the major forums and organise yourself better: At least have access to Excel on a computer and learn the basics of VBA. If you are trying to make a career of posting other people’s questions and getting answers for them, as many people do, then you have made the mistake of making it too obvious. Many of the senior helpers at the main forums prefer to think that they are helping people rather than doing their work for them. What they don’t know, does not hurt them. :)


I will leave all your posts in the main forum for a few weeks. Then I will move them all to the test forum. I will probably further merge them. Eventually I may delete them all.


Bro, whatever you are trying to do, its not working. Its never going to work. Its just wasting everybody’s time.
You need first to learn English
Then get a computer.
Then learn some basic Excel and Excel VBA
Then start again.



I have not been so impressed with my flower efforts this Summer. I will give Petra the blame for that: Do you remember my great success with the Sun Flowers in the wheelbarrow (https://imgur.com/hF1B4I1 )
Well Petra was not so impressed, she didn’t think it was so nice a wheelbarrow exploding with Sun Flowers, so as a compromise we said we would do it every other year.
But at the end of last year I must have got a few hundred seeds from the flowers. I planted about 100 of them all over the place at the start this year.
It was not a great success, possibly because we have so much shade, almost everywhere. I only noticed 3 growing, 2 still have not got very far. But a combination of intelligence and some nice late Summer sun has got the one up and he is letting everyone see him ….. first it grew about 80cm vertically to get out of the shade, then when it got out in the open it shot up.
https://imgur.com/IRW78eD
https://imgur.com/xKSfRU9
The clever Sun Flower. I must make a point of saving his seeds. ….

[DocAElstein]

Macro for this post
https://excelfox.com/forum/showthread.php/2568-Autofill-and-Reverse-Autofill?p=14572&viewfull=1#post14572

_ 4.
This is easy, simply convert the Target.Value to UCase(Target.Value) , and use that converted character in place of Target.Value
( If the Target.Value is already uppercase, then UCase(Target.Value) will not error - Target.Value will just stay as it is )

_ 2. And 3.
This is not difficult, but need s some juggling around with code lines
Two similar code sections are needed

_1. This is a bit more difficult. It is rather unusual not to have a range of the required LookUp information somewhere
This information must come from somewhere.
The most simple solution would be to have that range somewhere
For now , I have put the information on a second worksheet. And made a minor change to the macro to reference that worksheet
If this is not acceptable, then I can put the information somewhere else, such as in the macro itself.



So here is my next solution for you.
Once again for now, for clarity and simplicity, I have limited it just to a few rows


Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Bed
If Application.Intersect(Target, Me.Range("C3:F5")) Is Nothing Then Exit Sub ' No overlap with the entry range, so exit sub
' Case1
If Not Application.Intersect(Target, Me.Range("C3:C5")) Is Nothing Then ' Column C entry
If IsArray(Target.Value) Then Exit Sub ' more than one cell selected, but this procedure can only work on single cell entries in column C
If Target.Value = "" Then 'This would be a cleared cell ( deleted value )
Let Application.EnableEvents = False ' This is to prevent the worksheet change in the next code line setting off this procedure again
Let Target.Offset(0, 1).Resize(1, 3).Value = "" ' If I delete the Alpha Code from a cell (for example C3), the corresponding range (D3:F3) should be empty/deleted automatically.
Let Application.EnableEvents = True
ElseIf Len(Target.Value) <> 1 Then Exit Sub ' we have an entry , but it is invalid
Else
End If
Dim UcsTgtVl As String: Let UcsTgtVl = UCase(Target.Value)
If InStr(1, ",A,B,C,D,E,", "," & UcsTgtVl & ",", vbBinaryCompare) = 0 Then Exit Sub
Dim PosS As Long: Let PosS = (InStr(1, ",A,B,C,D,E,", UcsTgtVl, vbBinaryCompare) / 2) + 2 ' Row number in REFERENCE CHART for the corrsponding Sex Category Area values
Let Application.EnableEvents = False ' This is to prevent the worksheet change in the next code line setting off this procedure again
Let Target.Offset(0, 1).Resize(1, 3).Value = ThisWorkbook.Worksheets("REFERENCE CHART").Range("T" & PosS & ":V" & PosS & "").Value
Let Application.EnableEvents = True
' Case2
ElseIf Not Application.Intersect(Target, Me.Range("D3:F5")) Is Nothing Then ' Entry in column D E or F
If Target.Columns.Count = 1 Then
If Target.Value = "" Then 'This would be a cleared cell ( deleted value )
Let Application.EnableEvents = False ' This is to prevent the worksheet change in the next code line setting off this procedure again
Let Me.Range("C" & Target.Row & "").Value = "" ' If I delete any one cell value from the range (for example D3:F3), the corresponding Alpha Code (C3) should be deleted automatically. It means, the Alpha Code should be appear only if all the three cells in the corresponding range (for example D3:F3) are filled. Otherwise, the Alpha Code should be disappear/deleted.
Let Application.EnableEvents = True
Exit Sub
Else
End If
ElseIf Target.Rows.Count <> 1 Then Exit Sub ' more than 1 row selected, but this procedure can only work on single row entries
Else
End If
Dim arrSCA() As Variant: Let arrSCA() = Array("BOYGENURBAN", "BOYOBCURBAN", "BOYSCURBAN", "BOYSTURBAN", "GIRLGENURBAN")
Dim TrgtRw As Long: Let TrgtRw = Target.Row
Dim DEF As String: Let DEF = Me.Range("D" & TrgtRw).Value & Me.Range("E" & TrgtRw).Value & Me.Range("F" & TrgtRw).Value
Dim Mtchres As Variant
Let Mtchres = Application.Match(DEF, arrSCA, 0)
If IsError(Mtchres) Then Exit Sub ' no matching set of entries in columns D E and F
Dim PosS2 As Long: Let PosS2 = Mtchres + 2 ' Row number in REFERENCE CHART for the corresponding Alpha Code
Let Application.EnableEvents = False
Let Me.Range("C" & TrgtRw & "").Value = Me.Range("S" & PosS2 & "").Value
Let Application.EnableEvents = True
Else
End If

Bed: ' just incase anything goes wrong, it is a good idea to make sure that things are turned back to normal
Let Application.EnableEvents = True
End Sub



Share ‘Autofill.xlsm’ : https://app.box.com/s/mt1c2xvdejjj6d3vjo6wkjyrdxrs98tm

[DocAElstein]

Post for later use



“Moderator” Notice

**I am Banning you to prevent you making any more postings here of the type you have been making here and elsewhere under hundreds of different user names at many of the English speaking Excel and Office help forums for the last couple of years.

The type of post that you have been posting suggest that
_ You may be one person or a !!team of many people working at something organised like a Call Centre.
( !! Sometime when you have been “caught” cross posting, you did not know yourself where you cross posted, and asked to be told. ( Or you maybe only wanted to admit to those where you got “caught”) )
_ You have almost no understanding of the English language
_ You may not have a computer and may have no access to Excel
_ You have no interest in Excel or Excel VBA
_ You have almost no knowledge or interest in any of the questions that you are asking
_ You may be simply offering a service of posting other peoples questions and supplying them with any answers you get.
_ You may be part of the development of a question asking and Replying Bot

_ In some cases, something extremely simple to understand, has been explained to you in great detail , even graphically, such that even a small mentally handicapped child could understand it and remember it. Despite this, you continually ask exactly that same question over and over again: If you are part of a team interested in only posting questions and taking the answer, then you are very badly organised,
Or
There is no real intelligence behind what is producing your questions and posts
_ One of the things you consistently do after receiving a macro is to delete all explanations, explaining 'comments and all files associated, and indeed it appears as if you try to remove almost all record of the coding and the question and answer. This further encourages the posting of the same or similar questions over and over again.

Whatever you are attempting to do, it appears to be extremely, almost insanely, inefficient ,
compared to
a single person with a computer and Excel, and a minimum of basic Excel VBA knowledge trying to achieve the same.

The main reason for the ban is
Whatever you are attempting to do, it is requiring 10-100 times more time than is typically required of helpers at a forum. All indications are that what you are doing will fail to achieve anything, and is therefore a total waste of everyone’s time. At excelfox, the current small number of helpers have only a limited amount of time, but even if we had more members, excelfox would not be the place for you## Some of the major forums may be a good place for you to post.

These are some suggestions, from me, on how you should continue
_ If you intend to continue, regardless of any of my previous suggestions, in postings of the type as you have done in the past, then you should think about making some changes to your wording, introduce some new canned replies, possibly organise a new set of similar questions and post at the major forums, such as mrexcel.com, excelforum.com, ozgrid.com
_ If you wish to make a career out of posting questions and getting answers with out having any real intentions of thinking about anything, then excelfox is not the forum for you to post in. Most of the smaller forums are not the place for you. The larger forums may be able to accommodate you, if you give at least some thought to making it not quite so obvious: Your distinguishing characteristic is that ylou have been making it much more obvious than others doing the same, do: Many people do the such. At least half the traffic at such forums originates from such. I have passed many people on to such forums and they are making a successful career based on passing on the work done for them by helpers at the major forums. Such is actually encouraged, all be it , not openly, at the major forums.
_ If you have not understood most of this Moderator Notice , then your first priority should be to improve on your English. Indeed, your apparent understanding and ability in communicating in English suggests that you will achieve nothing whatsoever and fail completely in anything at all involving communicating in English.

_ If you are, as you sometimes told me via PM, actively working on an important personal problem requiring VBA , then you are doing it totally wrongly: You have been on the project already for at least two years and have a mixed up set of codings produced by many different people. Some work . Some don’t. You have not the slightest idea or understanding of any of the codings. You will never be able to use them to any effect. If , on the other hand, you had a computer, with Excel, and spent a few weeks learning VBA, and then carefully studied all the macros that you have been given, then you would be able to answer most of your further questions, and would have at least a chance of being able to use the codings effectively:-
1 Month learn VBA – 1 month getting answers, partly alone, partly with help from forums = Finished Success
2+ Years posting almost the same questions and just taking the answers = Never Ending Fail


##The main purpose of the question section of excelfox is approximately the following:
_1. Promote and improve the understanding of Excel and Excel VBA.
_2. Help people who get stuck on a problem and/or help people who are unsure how to proceed in solving a problem using Excel and Excel VBA.

Your objectives??
I do not know what the true reason is behind your postings. I can’t believe anything you say is your purpose, since you have lied and contradicted yourself in the past. The only thing we know 100% for sure is that your posting types are not for any of the purposes for which the question section of excelfox is intended.
You have had the benefit of the doubt given to you now very many times. You have had lots of chances.
You may be able to continue at some of the major forums, where some people are happy to continue to spend time to answer similar questions from the same source.
I do not think you will get any more replies to the types of postings you have been making at excelfox or at any other of the smaller English speaking Forums. You are wasting your time making any such posts from now on.
**I am Banning you, not as any form of punishment, but purely as in the past , it has proven to be the only way to prevent you wasting yours and other peoples time with your postings.
I do wish you luck and success with what ever it is you are attempting to do. But you should not be doing it at excelfox.
If you are attempting the personal project that you have told me about via PM, then you are going about it in completely the wrong way.
If you are trying to make a career of posting other people’s questions and getting answers for them, then you should post mostly at the major forums and organise yourself better: At least have access to Excel on a computer and learn the basics of VBA. If you are trying to make a career of posting other people’s questions and getting answers for them, as many people do, then you have made the mistake of making it too obvious. Many of the senior helpers at the main forums prefer to think that they are helping people rather than doing their work for them. What they don’t know, does not hurt them. :)

[DocAElstein]

Post for later use _

[DocAElstein]

Worked example for this Thread
https://excelfox.com/forum/showthread.php/2622-Reserve-the-Horizontal-line-numbers-and-information-but-the-calculation-result-is-change

Before: as supplied by OP

_____ Workbook: help0824.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJK
15ITEMDESCRIPTIONQTYUNITUNIT PRICETOTAL AMOUNTREMARKS

16133090

17

182201.530

193455220

20

2141250250

22

23

24

25

26

27

28

29

30

31

32

33

34

35Total7310.00
Worksheet: Sheet2

After
The macro is an events coding macro so it starts automatically,
....For example, I do the given example... ....'Example:
'Suppose the user fills in 3 in Cell G20, user fills in 15.25 in Cell I20 ,
'the serial number of Cell A20 serial number will automatic become 4,
' and the original 4 of cell A21 will automatically become 5
'
'At this time, G35 original is 7 , will automatically calculates 10,
' J20 automatically calculates 45.75
'At this time, J35 original is 310 , will automatically calculates 355.75

_____ Workbook: help0824.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJK
15ITEMDESCRIPTIONQTYUNITUNIT PRICETOTAL AMOUNTREMARKS

16133090

17

182201.530

193455220

204315.2545.75

2151250250

22

23

24

25

26

27

28

29

30

31

32

33

34

35Total10355.75
Worksheet: Sheet2

[DocAElstein]

Macro for last post, and for answer to this Thread
https://excelfox.com/forum/showthread.php/2622-Reserve-the-Horizontal-line-numbers-and-information-but-the-calculation-result-is-change?p=14831&viewfull=1#post14831



Public Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("G16:G34")) Is Nothing Or Not Application.Intersect(Target, Range("I16:I34")) Is Nothing Then ' we only go any further if we have an intersect between Target - the range we changed, and one of the column ranges of interest
If Range("A" & Target.Row & "").Value2 = "" Then ' We are only intertsted in putting a value in column A to update an ittem number if there is not already one in there
' get current maximum item number info: wjat is it, and where is it
Dim Cnt As Long, Mx As Long, MxInd As Long ' MxInd is for the Item number at which we got the maximum , - I need this to know where to put the new ITEM
Dim RngA As Range: Set RngA = Range("A16:A34")
For Cnt = 1 To RngA.Rows.Count Step 1
If Mx < RngA.Item(Cnt).Value Then ' In Excel Ranges cell item numbers are counted along columns then next rows etc. So for a single column, each next item number is the next row
Let Mx = RngA.Item(Cnt).Value
Let MxInd = Cnt
Else

End If
Next Cnt
' update current row item number to be the current highest, and make previous highest one more
Let Application.EnableEvents = False ' I have to temporarily turn this thing off, or else the next line makes this macro start again
Let Range("A" & Target.Row & "").Value2 = Mx: Let RngA.Item(MxInd).Value2 = Mx + 1
Let Application.EnableEvents = True
Else
' Column A already has a number in so no item number update
End If
' Doing the sum calculations
Dim RngG As Range: Set RngG = Range("G16:G34")
Dim RngJ As Range: Set RngJ = Range("J16:J34")
For Cnt = 1 To RngG.Rows.Count Step 1
Dim SumG As Double
If RngG.Item(Cnt).Font.Strikethrough = False And RngG.Item(Cnt).Value2 <> "" Then
Let SumG = SumG + RngG.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Dim SumJ As Double
If RngJ.Item(Cnt).Font.Strikethrough = False And RngJ.Item(Cnt).Value2 <> "" Then
Let SumJ = SumJ + RngJ.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Next Cnt
Let Application.EnableEvents = False
Let Range("G35").Value2 = SumG: Let Range("J35").Value2 = SumJ
Let Application.EnableEvents = True
Else
' did not make change in column ranges of interset
End If
End Sub

[DocAElstein]

Second solution for this Thread
https://excelfox.com/forum/showthread.php/2622-Reserve-the-Horizontal-line-numbers-and-information-but-the-calculation-result-is-change

Looking at jindon’s solution at the cross post:
https://www.excelforum.com/excel-programming-vba-macros/1325405-reserve-the-horizontal-line-numbers-and-information-but-the-calculation-result-is-change.html

Jindon has done a function to do the summing of the columns G and J

He sugest that, for example you place then in cell J35
=SumIfClear(J16:J34) https://www.excelforum.com/excel-programming-vba-macros/1325405-reserve-the-horizontal-line-numbers-and-information-but-the-calculation-result-is-change.html#post5386274

What this does is , taken in the column range, rng , and return the sum value as required.
It does it like this:
' make a range object , x , of a few areas, each area being a row with a “shape with a name Like "Line*"
' The sum calculation is then done only taking row values in the column, range , rng , which do not intersect with the range of rows with a shape, x

Option Explicit
' https://www.excelforum.com/excel-programming-vba-macros/1325405-reserve-the-horizontal-line-numbers-and-information-but-the-calculation-result-is-change.html
Sub CallSumIfClear()
Call SumIfClear(Range("J16:J34"))

End Sub
Function SumIfClear(rng As Range) As Double
Dim r As Range, x As Range, Sp As Shape
'Application.Volatile
' make a range object of a few areas, each area being a row with a shape with a name Like "Line*"
For Each Sp In rng.Worksheet.Shapes
If Sp.Name Like "Line*" Then
If x Is Nothing Then
Set x = Range(Sp.TopLeftCell, Sp.BottomRightCell)
Else
Set x = Union(x, Range(Sp.TopLeftCell, Sp.BottomRightCell))
End If
End If
Next
' The sum calculation
For Each r In rng
If Intersect(r, x) Is Nothing Then SumIfClear = SumIfClear + Val(r.Value)
Next
End Function


( The formula given by Jindon is no good as it does not answer the question )



Jindon’s formula has shown me how to determine where shapes ( like a line ) are.
So I could, for example, build a string of the row numbers with a shape in

For example this next macro , will return, for the sample data, in the variable, strLnRws ,
__18__21__

Sub BuildStingOfRowsWithShapeLine()
Dim strLnRws As String: Let strLnRws = " "
Dim RngG As Range: Set RngG = Range("G16:G34")
Dim Sp As Shape
For Each Sp In RngG.Worksheet.Shapes
If Sp.Name Like "Line*" Then
Let strLnRws = strLnRws & Sp.TopLeftCell.Row & " "
Else
End If
Next
Debug.Print strLnRws ' From VB Editor , hit keys Ctrl + g to get the immediate window to see the contents
End Sub



I can check for the rows so as not to sum those rows. ( Note I will check for a string of “ “ & TheRowNumber & “ “ , as this will avoid errors caused by checking for , for example 3 , when I have a row of 436 : If I checked for 3 , I would find it if I had 436 , which would be incorrect )

For example, the Instr function can be used to see if a row number is present in that strLnRws. Thuis is implimented in the example below to get the sum for column G

Sub BuildStingOfRowsWithShapeLineAndSumColumnIfNoShape Line()
Dim strLnRws As String: Let strLnRws = " "
Dim RngG As Range: Set RngG = Range("G16:G34")
Dim Sp As Shape
For Each Sp In RngG.Worksheet.Shapes
If Sp.Name Like "Line*" Then
Let strLnRws = strLnRws & Sp.TopLeftCell.Row & " "
Else
End If
Next
Debug.Print strLnRws ' From VB Editor , hit keys Ctrl + g to get the immediate window to see the contents

Dim Cnt
For Cnt = 1 To RngG.Rows.Count Step 1
Dim SumG As Double
If InStr(1, strLnRws, " " & RngG.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngG.Item(Cnt).Value2 <> "" Then ' InStr will return a 0 if the rows number is not present in the string strLnRws
Let SumG = SumG + RngG.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Next Cnt
Debug.Print SumG
End Sub



Using the above information we can write a second event coding macro which this time will work on the original worksheet: there is no longer a need to modify the range to have strikethroughs:
See next post

[DocAElstein]

Macro for last post, and for second answer to this Thread
https://excelfox.com/forum/showthread.php/2622-Reserve-the-Horizontal-line-numbers-and-information-but-the-calculation-result-is-change?p=14831&viewfull=1#post14831



Public Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("G16:G34")) Is Nothing Or Not Application.Intersect(Target, Range("I16:I34")) Is Nothing Then ' we only go any further if we have an intersect between Target - the range we changed, and one of the column ranges of interest
If Range("A" & Target.Row & "").Value2 = "" Then ' We are only intertsted in putting a value in column A to update an ittem number if there is not already one in there
' get current maximum item number info: wjat is it, and where is it
Dim Cnt As Long, Mx As Long, MxInd As Long ' MxInd is for the Item number at which we got the maximum , - I need this to know where to put the new ITEM
Dim RngA As Range: Set RngA = Range("A16:A34")
For Cnt = 1 To RngA.Rows.Count Step 1
If Mx < RngA.Item(Cnt).Value Then ' In Excel Ranges cell item numbers are counted along columns then next rows etc. So for a single column, each next item number is the next row
Let Mx = RngA.Item(Cnt).Value
Let MxInd = Cnt
Else

End If
Next Cnt
' update current row item number to be the current highest, and make previous highest one more
Let Application.EnableEvents = False ' I have to temporarily turn this thing off, or else the next line makes this macro start again
Let Range("A" & Target.Row & "").Value2 = Mx: Let RngA.Item(MxInd).Value2 = Mx + 1
Let Application.EnableEvents = True
Else
' Column A already has a number in so no item number update
End If
' Doing the sum calculations
Dim RngG As Range: Set RngG = Range("G16:G34")
' Build Sting Of Rows With Shape Line And Sum Column If No Shape Line https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)-Event-Coding?p=14844&viewfull=1#post14844
Dim strLnRws As String: Let strLnRws = " "
Dim Sp As Shape
For Each Sp In RngG.Worksheet.Shapes
If Sp.Name Like "Line*" Then
Let strLnRws = strLnRws & Sp.TopLeftCell.Row & " "
Else
End If
Next
Dim RngJ As Range: Set RngJ = Range("J16:J34")
For Cnt = 1 To RngG.Rows.Count Step 1
Dim SumG As Double
If InStr(1, strLnRws, " " & RngG.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngG.Item(Cnt).Value2 <> "" Then
Let SumG = SumG + RngG.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Dim SumJ As Double
If InStr(1, strLnRws, " " & RngJ.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngJ.Item(Cnt).Value2 <> "" Then
Let SumJ = SumJ + RngJ.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Next Cnt
Let Application.EnableEvents = False
Let Range("G35").Value2 = SumG: Let Range("J35").Value2 = SumJ
Let Application.EnableEvents = True
Else
' did not make change in column ranges of interset
End If
End Sub



I have put this in the worksheet object code module of worksheet "Sheet2 excelforum jindon" in the uploaded file: -
help0824.xls : https://app.box.com/s/fkfuld8yk4xrna5vt069x75intiyzs8i

[DocAElstein]

Macro for this post
https://excelfox.com/forum/showthread.php/2622-Reserve-the-Horizontal-line-numbers-and-information-but-the-calculation-result-is-change?p=14848&viewfull=1#post14848

In ThisWorkbook code module

Option Explicit
Private Sub Workbook_Open()
Let Sheet3.UsdRws = Worksheets.Item(3).UsedRange.Rows.Count
End Sub

In third worksheets object code module

Option Explicit
Public UsdRws As Long
Public Sub Worksheet_Change(ByVal Target As Range)
If Me.UsedRange.Rows.Count = UsdRws + 1 Then ' We added a row
Let Application.EnableEvents = False
Let Range("J" & Target.Row & "").Value = "=IF(OR(RC[-3]="""",RC[-1]=""""),"""",RC[-3]*RC[-1])"
Let Application.EnableEvents = True
Let UsdRws = UsdRws + 1
Exit Sub ' No more will be done after a row insert
Else
End If

If Not Application.Intersect(Target, Range("G16:G34")) Is Nothing Or Not Application.Intersect(Target, Range("I16:I34")) Is Nothing Then ' we only go any further if we have an intersect between Target - the range we changed, and one of the column ranges of interest Note: this would also be set off by a row insertion, but we will not let it because we exited before
' Dynamic Lr
Dim Lr As Long: Let Lr = Range("J" & Rows.Count & "").End(xlUp).Row - 1
If Range("A" & Target.Row & "").Value2 = "" Then ' We are only intertsted in putting a value in column A to update an ittem number if there is not already one in there
Let Application.EnableEvents = False
Let Range("A" & Target.Row & "").Value2 = "anything" ' Put anything in for now
Let Application.EnableEvents = True
Dim RngA As Range: Set RngA = Range("A16:A" & Lr & "")
Dim Cnt As Long, ACel As Range
For Each ACel In RngA.SpecialCells(xlCellTypeConstants) ' Each cell with something in it in column A
Let Cnt = Cnt + 1
Let Application.EnableEvents = False
Let ACel.Value = Cnt ' The next cell down is given the next number
Let Application.EnableEvents = True
Next ACel
Else
' Column A already has a number in so no item number update
End If
' Doing the sum calculations
Dim RngG As Range: Set RngG = Range("G16:G" & Lr & "")
' Build Sting Of Rows With Shape Line And Sum Column If No Shape Line https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)-Event-Coding?p=14844&viewfull=1#post14844
Dim strLnRws As String: Let strLnRws = " "
Dim Sp As Shape
For Each Sp In RngG.Worksheet.Shapes
If Sp.Name Like "Line*" Then
Let strLnRws = strLnRws & Sp.TopLeftCell.Row & " "
Else
End If
Next
Dim RngJ As Range: Set RngJ = Range("J16:J" & Lr & "")
For Cnt = 1 To RngG.Rows.Count Step 1
Dim SumG As Double
If InStr(1, strLnRws, " " & RngG.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngG.Item(Cnt).Value2 <> "" Then
Let SumG = SumG + RngG.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Dim SumJ As Double
If InStr(1, strLnRws, " " & RngJ.Item(Cnt).Row & " ", vbBinaryCompare) = 0 And RngJ.Item(Cnt).Value2 <> "" Then
Let SumJ = SumJ + RngJ.Item(Cnt).Value2
Else
' there is no value or it is struck through
End If
Next Cnt
Let Application.EnableEvents = False
Let Range("G" & Lr + 1 & "").Value2 = SumG: Let Range("J" & Lr + 1 & "").Value2 = SumJ
Let Application.EnableEvents = True
Else
' did not make change in column ranges of interset
End If
End Sub

[DocAElstein]

In support of this Thread answer

List table supplied by OP in uploade file

_____ Workbook: Book1.xlsx ( Using Excel 2007 32 bit )
Row\ColAMANAOAPAQARASATAUAVAWAXAYAZBABB
15(Select Here)

16Nuclear Family(Remark if any)

17Joint Family(Remark if any)

18Single-Parent Family(Select Reason)

19Expired

20Divorced

21Break-Up

22Abandonment

23Enter Reason Manually

24Joint Family(Please Specify the Case)
Worksheet: Sheet1


I am not sure why get those strange black areas , so I did a find on replacing withnothing


_____ Workbook: Book1.xlsx ( Using Excel 2007 32 bit )
Row\ColAMANAOAPAQARASATAUAVAWAXAYAZBABB
15(Select Here)[/td][/td][/td][/td][/td][/td]

16Nuclear Family[/td][/td][/td][/td][/td][/td][/td](Remark if any)[/td][/td][/td][/td][/td][/td][/td][/td][/td]

17Joint Family[/td][/td][/td][/td][/td][/td][/td](Remark if any)[/td][/td][/td][/td][/td][/td][/td][/td][/td]

18Single-Parent Family[/td][/td][/td][/td][/td][/td][/td](Select Reason)[/td][/td][/td][/td][/td][/td][/td][/td][/td]

19Expired[/td][/td][/td][/td][/td][/td][/td][/td][/td]

20Divorced[/td][/td][/td][/td][/td][/td][/td][/td][/td]

21Break-Up[/td][/td][/td][/td][/td][/td][/td][/td][/td]

22Abandonment[/td][/td][/td][/td][/td][/td][/td][/td][/td]

23Enter Reason Manually[/td][/td][/td][/td][/td][/td][/td][/td][/td]

24Joint Family[/td][/td][/td][/td][/td][/td][/td](Please Specify the Case)[/td][/td][/td][/td][/td][/td][/td][/td][/td]
Worksheet: Sheet1

So I did a find on [td=bgcolor:#000000] replacing with [td]

_....see next post

[DocAElstein]

_... from last post

_____ Workbook: Book1.xlsx ( Using Excel 2007 32 bit )
Row\ColAMANAOAPAQARASATAUAVAWAXAYAZBABB
15(Select Here)

16Nuclear Family(Remark if any)

17Joint Family(Remark if any)

18Single-Parent Family(Select Reason)

19Expired

20Divorced

21Break-Up

22Abandonment

23Enter Reason Manually

24Joint Family(Please Specify the Case)
Worksheet: Sheet1

Some Immediate window results
? Range("AM15").font.ThemeColor
7
? Range("AM15").font.TintAndShade
0
? Range("AM15").font.Color
10855845
? Range("AM15").font.Colorindex
48
? Range("AM16").font.tintandshade
0
? Range("AM16").font.Bold
Falsch
? Range("AM16").font.Color
6751362
? Range("AM16").font.Colorindex
13
? Range("AM16").font.Bold
Falsch
? Range("AT19").Font.Tintandshade
0
? Range("AT19").Font.Color
0
? Range("AT19").Font.colorindex
-4105
? Range("AT19").Font.Bold
Falsch

[DocAElstein]

Just testing in this post.....


_____ Workbook: Book1.xlsx ( Using Excel 2007 32 bit )
Row\ColAMANAOAPAQARASATAUAVAWAXAYAZBABB

16(Select Here)

16Nuclear Family(Remark if any)

17Joint Family(Remark if any)

18Single-Parent Family(Select Reason)

19Expired

20Divorced

21Break-Up

22Abandonment

23Enter Reason Manually

24Joint Family(Please Specify the Case)
Worksheet: Sheet1

[DocAElstein]

Solution for ( part A) ) of this Thread
https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14870&viewfull=1#post14870


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$J$19" Then
If Target.Value = "" Then
Let Application.EnableEvents = False
Let Target.Value = "(Select)"
Let Application.EnableEvents = True
With Target.Font
.Color = 10855845
'.ColorIndex = 48
End With
ElseIf Target.Value = "Nuclear Family" Or Target.Value = "Joint Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Remark if any)"
Let Application.EnableEvents = True
With Range("R19").Font
.Color = 10855845
'.ColorIndex = 48
End With
ElseIf Target.Value = "Single-Parent Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Select Reason)"
Let Application.EnableEvents = True
With Range("R19").Font
.Color = 10855845
'.ColorIndex = 48
End With
ElseIf Target.Value = "Uncategorised" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Please Specify the Case)"
Let Application.EnableEvents = True
With Range("R19").Font
.Color = 10855845
'.ColorIndex = 48
End With
End If
Else
' Target is Not a cell to be acted on
End If
End Sub

'Row\Col AM AN AO AP AQ AR AS AT AU AV AW AX AY AZ BA BB
'16 (Select Here)
'16 Nuclear Family (Remark if any)
'17 Joint Family (Remark if any)
'18 Single-Parent Family (Select Reason)
'19 Expired
'20 Divorced
'21 Break -Up
'22 Abandonment
'23 Enter Reason Manually
'24 Joint Family (Please Specify the Case)



'Print Range("AM15").Font.ThemeColor
'7
'Print Range("AM15").Font.TintAndShade
'0
'Print Range("AM15").Font.Color
'10855845
'Print Range("AM15").Font.ColorIndex
'48
'Print Range("AM16").Font.TintAndShade
'0
'Print Range("AM16").Font.Bold
'Falsch
'Print Range("AM16").Font.Color
'6751362
'Print Range("AM16").Font.ColorIndex
'13
'Print Range("AM16").Font.Bold
'Falsch
'Print Range("AT19").Font.TintAndShade
'0
'Print Range("AT19").Font.Color
'0
'Print Range("AT19").Font.ColorIndex
'-4105
'Print Range("AT19").Font.Bold
'Falsch

[DocAElstein]

Answer to this Thread post:
https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14873&viewfull=1#post14873


Private Sub Worksheet_Change(ByVal Target As Range) ' https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14873&viewfull=1#post14873
If Target.Address = "$J$19" Or Target.Address = "$J$19:$P$19" Then ' we need "$J$19:$P$19" to make macro work on Delete probably because of merged cells
Dim RngTgt As Range: Set RngTgt = Target
If Target.Address = "$J$19:$P$19" Then Set RngTgt = Range("J19")
If RngTgt.Value = "" Then
Let Application.EnableEvents = False
Let RngTgt.Value = "(Select Here)"
Let Application.EnableEvents = True
Let RngTgt.Font.Color = 10855845
ElseIf RngTgt.Value = "Nuclear Family" Or RngTgt.Value = "Joint Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Remark if any)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
ElseIf RngTgt.Value = "Single-Parent Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Select Reason)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
ElseIf RngTgt.Value = "Uncategorised" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Please Specify the Case)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
End If
Else
' Target is Not a cell to be acted on
End If

If Target.Address = "$R$19" Then Let Target.Font.ColorIndex = xlAutomatic

End Sub

[DocAElstein]

In support of this püost:
https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14877&viewfull=1#post14877



Private Sub Worksheet_Change(ByVal Target As Range) ' https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14873&viewfull=1#post14873
If Target.Address = "$J$19" Or Target.Address = "$J$19:$P$19" Then ' we need "$J$19:$P$19" to make macro work on Delete probably because of merged cells
Dim RngTgt As Range: Set RngTgt = Target
If Target.Address = "$J$19:$P$19" Then Set RngTgt = Range("J19")
If RngTgt.Value = "" Then
Let Application.EnableEvents = False
Let RngTgt.Value = "(Select Here)"
Let Range("R19").Value = ""
Let Application.EnableEvents = True
Let RngTgt.Font.Color = 10855845
' Range("R19:Z19").Select
' With Selection
' .HorizontalAlignment = xlCenter
' .VerticalAlignment = xlCenter
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = True
' End With
ElseIf RngTgt.Value = "Nuclear Family" Or RngTgt.Value = "Joint Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Remark if any)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
ElseIf RngTgt.Value = "Single-Parent Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Select Reason)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
' The drop down validation list in cell R19 is produced when the value "Single-Parent Family" is selected in cell J19
' Range("R19").Select
With Range("R19").Validation 'With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="Expired,Divorced,Break-Up,Abandonment,Enter Reason Manually"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Error!"
.InputMessage = ""
.ErrorMessage = "To enter the reason manually, please select the option 'Enter Reason Manually'"
.ShowInput = True
.ShowError = True
End With

ElseIf RngTgt.Value = "Uncategorised" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Please Specify the Case)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
End If ' end of all values of J19 to result in actions
Else
' Target is not cell J19 ( or J19:P19 )
End If

' If Target.Address = "$R$19" Then Let Target.Font.ColorIndex = xlAutomatic
'
' If Target.Address = "$J$19" Then
' If Target.Value = "Single-Parent Family" Then
' Let Application.EnableEvents = False
' Let Range("R19").Value = "Select Reason..."
' Let Application.EnableEvents = True
' With Range("R19").Font
' .Color = -10477568
' .TintAndShade = 0
' End With
'' Target.Font.Size = 11.5
'
' End If


' If drop down list is present in cell R19 , and "Enter Reason Manually" is selected from that drop down list in R19, then the drop down validation list in cell R19 is removed.

If Target.Address = "$R$19" Then
Let Target.Font.ColorIndex = xlAutomatic
If Target.Value = "Enter Reason Manually" Then
' With Target.Validation ' Selection.Validation
' .Delete
Target.Validation.Delete
' .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
' :=xlBetween
' .IgnoreBlank = True
' .InCellDropdown = True
' .ShowInput = True
' .ShowError = True
' End With
' Selection.ClearContents
' With Target.Font
' .ThemeColor = xlThemeColorLight1
' .TintAndShade = 0
' End With
' Range("R19:Z19").Select
' With Selection
' .HorizontalAlignment = xlLeft
' .VerticalAlignment = xlCenter
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .ReadingOrder = xlContext
' .MergeCells = True
' End With
' Target.Font.Size = 11.5
End If
Else
' Target is not R19
End If


End Sub



Private Sub Worksheet_Change(ByVal Target As Range) ' https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14873&viewfull=1#post14873
If Target.Address = "$J$19" Or Target.Address = "$J$19:$P$19" Then ' we need "$J$19:$P$19" to make macro work on Delete probably because of merged cells
Dim RngTgt As Range: Set RngTgt = Target
If Target.Address = "$J$19:$P$19" Then Set RngTgt = Range("J19")
If RngTgt.Value = "" Then
Let Application.EnableEvents = False
Let RngTgt.Value = "(Select Here)"
Let Range("R19").Value = ""
Let Application.EnableEvents = True
Let RngTgt.Font.Color = 10855845
ElseIf RngTgt.Value = "Nuclear Family" Or RngTgt.Value = "Joint Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Remark if any)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
ElseIf RngTgt.Value = "Single-Parent Family" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Select Reason)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
' The drop down validation list in cell R19 is produced when the value "Single-Parent Family" is selected in cell J19
With Range("R19").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="Expired,Divorced,Break-Up,Abandonment,Enter Reason Manually"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Error!"
.InputMessage = ""
.ErrorMessage = "To enter the reason manually, please select the option 'Enter Reason Manually'"
.ShowInput = True
.ShowError = True
End With

ElseIf RngTgt.Value = "Uncategorised" Then
Let Application.EnableEvents = False
Let Range("R19").Value = "(Please Specify the Case)"
Let Application.EnableEvents = True
Let Range("R19").Font.Color = 10855845
Let RngTgt.Font.Color = 6751362
End If ' end of all values of J19 to result in actions
Else
' Target is not cell J19 ( or J19:P19 )
End If

' If drop down list is present in cell R19 , and "Enter Reason Manually" is selected from that drop down list in R19, then the drop down validation list in cell R19 is removed.
If Target.Address = "$R$19" Then
Let Target.Font.ColorIndex = xlAutomatic
If Target.Value = "Enter Reason Manually" Then
Target.Validation.Delete
Else
End If
Else
' Target is not R19
End If

End Sub

[DocAElstein]

First macro for this Post:
https://excelfox.com/forum/showthread.php/2633-Showing-Custom-Value-Based-on-the-Condition-of-Dynamic-Table?p=14913#post14913


Sub TestieCalls()
Call Me.Worksheet_Change(Me.Range("B4"))
End Sub

Public Sub Worksheet_Change(ByVal Target As Range)
Dim Lr As Long, Lc As Long
Let Lr = Me.Range("B" & Me.Rows.Count & "").End(xlUp).Row
Let Lc = Me.Cells(4, 2).End(xlToRight).Column ' I am using a slightly less common way including xlToRight because there are some explanation wordings that would be found giving a false number by the more typically used Columns.Count xlToLeft way
Dim RngTbl As Range: Set RngTbl = Me.Range("B4:" & CL(Lc) & Lr & "")
If Application.Intersect(Target, RngTbl) Is Nothing Then
Exit Sub ' I did not change anything in the table
Else
Let Application.EnableEvents = False
Let Me.Range("A1").Value = "No Remarks"
Let Application.EnableEvents = True
Rem Loop
Dim arrTbl() As Variant: Let arrTbl() = RngTbl.Value2
Dim Cnt
For Cnt = 1 To UBound(arrTbl(), 1) ' Loop "down" "rows" in table array
Dim Clm As Long: Let Clm = 2 ' "column" in table array
Dim Decs As Long
'For Clm = 2 To UBound(arrTbl(), 2) - 1 ' loop from second to last but one "column" in table array
Do
If arrTbl(Cnt, Clm + 1) >= arrTbl(Cnt, Clm) Then ' we no longer have a decresing sequence
Let Decs = 0 ' Reset the count of sequential decreasing values
Else ' we have at least 2 sequential decreses, possibly 3
Let Decs = Decs + 1
End If
'Next Clm
Let Clm = Clm + 1
Loop While Clm < UBound(arrTbl(), 2) And Decs < 2
'If Clm = UBound(arrTbl(), 2) Then ' this will occur if we did not exit the For loop
If Decs = 2 Then ' If decs = 2 we had three seqeuntial decreses = sequentially 2 x arrTbl(Cnt, Clm + 1) < arrTbl(Cnt, Clm)
Dim StrRemmark As String
Let StrRemmark = StrRemmark & " and " & arrTbl(Cnt, 1)
Else
End If
Let Decs = 0 ' reset the count of sequential decreasing values so that Decs can be used in the next main row loop
Next Cnt
End If
' add remark
If StrRemmark <> "" Then
Let StrRemmark = Mid(StrRemmark, 6) ' this takes off the first " and "
Let Application.EnableEvents = False
Let Me.Range("A1").Value = "Student is decreasing in " & StrRemmark
Let Application.EnableEvents = True
Else
' no remmark
End If
End Sub
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

[DocAElstein]

Final macro for this post
https://excelfox.com/forum/showthread.php/2633-Showing-Custom-Value-Based-on-the-Condition-of-Dynamic-Table?p=14913#post14913


' https://excelfox.com/forum/showthread.php/2633-Showing-Custom-Value-Based-on-the-Condition-of-Dynamic-Table?p=14913&viewfull=1#post14913
'Important:
' All of the above conditions are applied only if there are minimum 3 consecutive cells which are in descending order.
' For example, cells D5, E5 and F5 have values which are satisfied all the three condition, i.e, they are in descending order, and they are consecutive (side by side), and they are minimum three.

'
'Point 1) Missing comma: When all the three rows contains values in descending order, then B4 shows -
' Student is decreasing in ENGLISH and HINDI and MATHS
' It should be - Student is decreasing in ENGLISH, HINDI and MATHS (as we normally write in English language)

Sub TestieCalls()
Call Me.Worksheet_Change(Me.Range("B4"))
End Sub

Public Sub Worksheet_Change(ByVal Target As Range)
Dim Lr As Long, Lc As Long
Let Lr = Me.Range("B" & Me.Rows.Count & "").End(xlUp).Row
Let Lc = Me.Cells(4, 2).End(xlToRight).Column ' I am using a slightly less common way including xlToRight because there are some explanation wordings that would be found giving a false number by the more typically used Columns.Count xlToLeft way
Dim RngTbl As Range: Set RngTbl = Me.Range("B4:" & CL(Lc) & Lr & "")
If Application.Intersect(Target, RngTbl) Is Nothing Then
Exit Sub ' I did not change anything in the table
Else
Let Application.EnableEvents = False
Let Me.Range("A1").Value = "No Remarks"
Let Application.EnableEvents = True
Rem Loop
Dim arrTbl() As Variant: Let arrTbl() = RngTbl.Value2
Dim Cnt
For Cnt = 1 To UBound(arrTbl(), 1) ' Loop "down" "rows" in table array
Dim Clm As Long: Let Clm = 2 ' "column" in table array
Dim Decs As Long
'For Clm = 2 To UBound(arrTbl(), 2) - 1 ' loop from second to last but one "column" in table array
Do
If arrTbl(Cnt, Clm + 1) >= arrTbl(Cnt, Clm) Then ' we no longer have a decresing sequence
Let Decs = 0 ' Reset the count of sequential decreasing values
Else ' we have at least 2 sequential decreses, possibly 3
Let Decs = Decs + 1
End If
'Next Clm
Let Clm = Clm + 1
Loop While Clm < UBound(arrTbl(), 2) And Decs < 2
'If Clm = UBound(arrTbl(), 2) Then ' this will occur if we did not exit the For loop
If Decs = 2 Then ' If decs = 2 we had three seqeuntial decreses = sequentially 2 x arrTbl(Cnt, Clm + 1) < arrTbl(Cnt, Clm)
Dim StrRemmark As String
'Let StrRemmark = StrRemmark & " and " & arrTbl(Cnt, 1)
'Let StrRemmark = StrRemmark & ", " & arrTbl(Cnt, 1)
Let StrRemmark = StrRemmark & ", " & Left(arrTbl(Cnt, 1), 1) & Mid(LCase(arrTbl(Cnt, 1)), 2) ' This effectively changes something like MATHS to M & aths = Maths
Else
End If
Let Decs = 0 ' reset the count of sequential decreasing values so that Decs can be used in the next main row loop
Next Cnt
End If
' add remark
If StrRemmark <> "" Then
'Let StrRemmark = Mid(StrRemmark, 6) ' this takes off the first " and "
Let StrRemmark = Mid(StrRemmark, 3) ' this takes off the first ", "
Dim Pos As Long: Let Pos = InStrRev(StrRemmark, ", ", -1, vbBinaryCompare)
If Pos <> 0 Then ' Pos will be 0 if no ", " was found
Let StrRemmark = Application.WorksheetFunction.Replace(StrRemmark, Pos, 2, " and ") ' _3 WorksheetFunction.Replace Method https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Else
' we had no ", " in the final string , so we just have one subject
End If
Let Application.EnableEvents = False
Let Me.Range("A1").Value = "Student is decreasing in " & StrRemmark & "."
Let Application.EnableEvents = True
Else
' no remmark
End If
End Sub
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

[DocAElstein]

macro solution for this post:
https://excelfox.com/forum/showthread.php/2633-Showing-Custom-Value-Based-on-the-Condition-of-Dynamic-Table?p=14955&viewfull=1#post14955



Sub Testie() ' For testing in pre Office 2016
Call Me.Worksheet_Change(Me.Range("K74")) ' this simulates a change in cell K74
End Sub

Public Sub Worksheet_Change(ByVal Target As Range)
Dim Lr As Long, Lc As String ' Lc As Long
Let Lr = 81 ' Me.Range("B" & Me.Rows.Count & "").End(xlUp).Row
Let Lc = "S"
Dim RngTbl As Range ' : Set RngTbl = Me.Range("K74:" & Lc & Lr & "")
'or simply
Set RngTbl = Me.Range("K74:S81") ' Me.Range("B4:" & CL(Lc) & Lr & "")
If Application.Intersect(Target, RngTbl) Is Nothing Then
Exit Sub ' I did not change anything in the table
Else
Let Application.EnableEvents = False
Let Me.Range("H40").Value = "No Remarks" ' Me.Range("A1").Value = "No Remarks"
Let Application.EnableEvents = True
Rem We now get the array , arrDec() , directly from X74:X81
'Dim arrTbl() As Variant: Let arrTbl() = RngTbl.Value2
Dim arrDec() As Variant ' As Boolean: ReDim arrDec(1 To Lr - 3)
Let arrDec() = Me.Range("X74:X81").Value2
' We no longer need the data table range, but we do need the subject table/ column
Dim arrSubjs() As Variant
Let arrSubjs() = Me.Range("F74:F81").Value2
Dim Cnt
' For Cnt = 1 To UBound(arrTbl(), 1) ' Loop "down" "rows" in table array
' Dim Clm As Long ' "column" in table array
' For Clm = 2 To UBound(arrTbl(), 2) - 1 ' loop from second to last but one "column" in table array
' If arrTbl(Cnt, Clm + 1) >= arrTbl(Cnt, Clm) Then
' Let arrDec(Cnt) = True: Exit For ' we no longer have a decresing sequence
' Else
' End If
' Next Clm
' Next Cnt

End If

' at this point I have in my arrDec() 1 for a decreasing sequence and "" for a non decreasing sequence
Rem loop to build the output string
Dim StrRemmark As String
For Cnt = 1 To UBound(arrDec(), 1)
If arrDec(Cnt, 1) = 1 Then ' False Then
'Let StrRemmark = StrRemmark & " and " & arrSubjs(Cnt, 1)
Let StrRemmark = StrRemmark & ", " & Left(arrSubjs(Cnt, 1), 1) & Mid(LCase(arrSubjs(Cnt, 1)), 2) '
Else
End If
Next Cnt
' add remark
If StrRemmark <> "" Then
'Let StrRemmark = Mid(StrRemmark, 6) ' this takes off the first " and "
Let StrRemmark = Mid(StrRemmark, 3) ' this takes off the first ", "
Dim Pos As Long: Let Pos = InStrRev(StrRemmark, ", ", -1, vbBinaryCompare)
If Pos <> 0 Then ' Pos will be 0 if no ", " was found
Let StrRemmark = Application.WorksheetFunction.Replace(StrRemmark, Pos, 2, " and ") ' _3 WorksheetFunction.Replace Method https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Else
' we had no ", " in the final string , so we just have one subject
End If

Let Application.EnableEvents = False
'Let Me.Range("A1").Value = "Student is decreasing in " & StrRemmark
Let Me.Range("H40").Value = "Decline in " & StrRemmark & "."
Let Application.EnableEvents = True
Else
' no remmark
End If
End Sub


'Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
' Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
'End Function

[DocAElstein]

post for later use,
posting to get URL limk now

[DocAElstein]

Sub test()
SendKeys "%s{Enter}"
MsgBox ("please just click OK")
End Sub

' https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14885&viewfull=1#post14885
' https://excelfox.com/forum/showthread.php/2624-Drop-Down-Menu-with-Multiple-Conditions?p=14877&viewfull=1#post14877
' https://excelfox.com/forum/showthread.php/2630-Auto-Show-Drop-Down-List-When-Selecting-the-Cell
' http://www.eileenslounge.com/viewtopic.php?p=277023#p277023

[DocAElstein]

Insupport of this Thread post:
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15085#post15085


Sub MakeDropDownList1and2() ' https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15085&viewfull=1#post15085
Rem 1 worksheets info
Dim WsApp As Worksheet, WsComs As Worksheet
Set WsApp = ThisWorkbook.Worksheets("Appraisal"): Set WsComs = ThisWorkbook.Worksheets("Comments")
Rem 2 FirstTwoDropDowns2
' 2a) List 1 in column A
WsApp.Range("A2:A8").Validation.Delete
WsApp.Range("A2:A8").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A1").Value & "," & WsComs.Range("A11").Value & "," & WsComs.Range("A21").Value & "," & WsComs.Range("A31").Value & ""

'2b) list 2 in column C
WsComs.Range("C2:C8").Validation.Delete
WsComs.Range("C2:C8").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A2").Value & "," & WsComs.Range("B2").Value & "," & WsComs.Range("C2").Value & ""
End Sub

[DocAElstein]

Notes in support of this thread:
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists
Following approximately these steps:
https://support.microsoft.com/en-us/office/create-a-drop-down-list-7693307a-59ef-400a-b769-c5402dce407b
Worksheets info from OP:
Requirements:

1. Under "Social Competencies", the drop down list should contain all the headers from the sheet "Comments" (Color Code - Peach).

2. Under "Please Choose", the drop down list should contain "Does Not Meet Expectation", "Meets Expectation", "Exceeds Expectation" (Color Code - Grey).

3. So, If a person selects "Communicating Effectively" under Social Competencies column, and then selects "Meets Expectation" in the next column, then the drop down list on Column D "Please Choose" should display the list from B3:B8 from the sheet named "Comments".

Another example would be if a person selects "Resolving Conflict" under Social Competencies column, and then selects "Does Not Meet Expectation" in the next column, then the drop down list on Column D "Please Choose" should display the list from A13:A18 from the sheet named "Comments".

4. So, If a person selects "Sharing Information" under Social Competencies column, then the drop down list on Column E "Give Advise" should display the list from A28:A32 from the sheet named "Give Advise"
_____ Workbook: Appraisal - Drop Down.xls ( Using Excel 2007 32 bit )
Row\ColABCDE
1SOCIAL COMPETENCIESPlease ChooseCommentsGive Advise

2

3

4

5

6

7

8
Worksheet: Appraisal



Continued in next post…._

[DocAElstein]

Continued in next post…._

_..... continued from last post
Worksheets info from OP:
Requirements:

1. Under "Social Competencies", the drop down list should contain all the headers from the sheet "Comments" (Color Code - Peach).

2. Under "Please Choose", the drop down list should contain "Does Not Meet Expectation", "Meets Expectation", "Exceeds Expectation" (Color Code - Grey).

3. So, If a person selects "Communicating Effectively" under Social Competencies column, and then selects "Meets Expectation" in the next column, then the drop down list on Column D "Please Choose" should display the list from B3:B8 from the sheet named "Comments".

Another example would be if a person selects "Resolving Conflict" under Social Competencies column, and then selects "Does Not Meet Expectation" in the next column, then the drop down list on Column D "Please Choose" should display the list from A13:A18 from the sheet named "Comments".

4. So, If a person selects "Sharing Information" under Social Competencies column, then the drop down list on Column E "Give Advise" should display the list from A28:A32 from the sheet named "Give Advise"


_____ Workbook: Appraisal - Drop Down.xls ( Using Excel 2007 32 bit )
Row\ColABC
1Communicating Effectively

2Does Not Meet ExpectationMeets ExpectationExceeds Expectation

3Assumes understanding.Actively listens.Encourages others to share information.

4Difficult to contact.Communicates regularly with team members.Excellent listener.

5Does not adapt language to listener.Communicates with team members.Gives people full attention.

6Does not give others full attention.Conveys enthusiasm.Promotes candid and open atmosphere.

7Ideas and comments are hard to follow.Gives people full attention.Shares information with team.

8Uses overly complex language.Shares information with team.Shares useful information.

9

10

11Resolving Conflict

12Does Not Meet ExpectationMeets ExpectationExceeds Expectation

13Becomes emotional dealing with conflict.Avoids emotional involvement.Diffuses conflicts before they start.

14Gives up easily, misses opportunities.Avoids unnecessary conflict.Finds permanent fixes to tough conflicts.

15Is caught off guard by conflicts.Handles difficult people.Handles difficult people easily.

16Needs to focus on problems, not people.Helps others end disputes.Listens to all, hears all sides.

17Shies away from conflict, lets it escalate.Tries to find roots of conflict.Top peacekeeper, solution-finder.

18Too confrontational, focused on win-lose.Uses good listening, communication skills.

19

20

21Sharing Information

22Does Not Meet ExpectationMeets ExpectationExceeds Expectation

23Does not communicate experience or knowledge to others.Effectively communicates information and keeps teammates on the same page.Carefully listens to what others have to say and adds insightful comments; asks important questions.

24Does not listen to others.Keep key players informed.Conveys extremely complex information in a simple fashion.

25Does not share relevant information to the team.Knows the appropriate amount of knowledge to share with others.Does not act aloof or arrogant, is humble and happy to help.

26Does not speak up.Prior to presenting and idea or sharing information, run it by someone first.Helps foster and cultivate an environment that is open to exchange of information.

27Shares too little information.Shares useful information with teammates.Informs the team with specific information to achieve and surpass goals.

28Shares useless information.Willingly shares leadership skills and knowledge with others.Provides expert information and knowledge with teammates.

29

30

31Supporting Co-workers

32Does Not Meet ExpectationMeets ExpectationExceeds Expectation

33Could be more collaborative.Appreciates others.Able to resolve conflict.

34Could be more open-minded.Collaborates with others.Excellent listening skills.

35Does not respond to others' needs.Helps resolve team conflicts.Flexible and open-minded.

36does not support new membersProactively share information and suggestions to help new team members get up to speed as fast as possible.Includes others.

37Excessively critical of others.Welcomes new team members.Promotes team spirit.

38Rarely accommodates others.Willing to help.Provides support.
Worksheet: Comments
Continued in next post…._

[DocAElstein]

_..........Continued from last post





_____ Workbook: Appraisal - Drop Down.xls ( Using Excel 2007 32 bit )
Row\ColA
1Communicating Effectively

2Effective communication can be challenging. Often, ineffective communication results from misunderstanding. Try not to get discouraged if at first others do not understand what you are saying. Make your best efforts to restate and clarify.

3Remember that effective communication requires listening skills. Think about how you would like others to listen when you are trying to explain something. Be that listener for others.

4When communicating with others, try to gauge your audience effectively. Gather adequate information in order to communicate as effectively as possible.

5Spend time organizing your thoughts before you write a document or give a presentation. Draw pictures or a timeline if that helps. Determine where you want your audience to be at the conclusion. Try to identify the optimal steps to get your audience where you want them to be.

6Rehearse and practice before giving presentations. Individuals who practice prior to presenting appear to be more effective communicators than those individuals who do not.

7Be sure to give your full attention to others. If you schedule a time to meet with someone be sure to actively be present.

8Take on projects where you can be the lead. This will allow you to help you hone your communication skills.

9Take on projects where a final document or presentation will be given to your teammates or superiors.

10Books you may find useful: Ekman, P. (2007). Emotions Revealed, Second Edition: Recognizing Faces and Feelings to Improve Communication and Emotional Life.; Alder, R. B., Elmhorst, J. M. (2008). Communicating at Work: Principles and Practices for Business and the Professions.; Alessandra, T. (1993). Communicating at Work.

11Books you may find useful: Lewis, G. (2000). The Mentoring Manager: Strategies for Fostering Talent and Spreading Knowledge.; Ingwersen, P., Jarvelin, K. (2005). The Turn: Integration of Information Seeking and Retrieval in Context.

12

13

14Resolving Conflict

15One difficulty in dealing with conflict is doing so without becoming emotionally invested. Highly emotional people may struggle with seeing the situation objectively. When people feel personally invested, it will become difficult to reach a resolution.

16It is common for people who struggle with negotiation to also struggle with conflict resolution. This is not surprising because both involve working with others to reach a common ground. Negotiation is often a critical skill in resolving conflict. It may be beneficial to try improving your negotiation skills in order to more effectively manage conflict.

17Wait a few seconds (or days) before answering. When a person says something to you that gets under your skin, give yourself the time you need to respond objectively and not react impulsively. That may take a couple seconds or it may require that you table the issue until you've had time or are in a better frame of mind to deal with it constructively.

18Put yourself in another person's position. Why is this person acting confrontational? What do they really want? What pressure is on them? Try to look a level deeper to find a point from which you can start a more productive conversation.

19Keep communication open. Get in the habit of asking all participants, especially the least vocal attendees, for their input. A simple """"""""What's your take on this, Bill?"""""""" or """"""""What do you think about that idea, Judy?"""""""" can often bring out valuable opinions or underlying issues. In order to do this, you'll also have to limit the time each person has to speak.

20Give your input objectively. Whether or not you feel intensely involved in the conflict, state your opinions on the issues objectively and independently. Avoid the appearance of taking sides. If your opinion is clearly on one side or the other, try to state it in terms different than those used by the disagreeing parties.

21Fix the process. Many conflicts and aggravation can be caused by systems and processes, or lack thereof. Work with the people involved to locate the sticking points and help them figure out how to change the process if it is causing problems.

22Try taking on a position as a conflict mediator. This can help you to see how conflicts tend to escalate, and how they tend to be resolved in the end. The more you observe conflicts and help others to resolve them, the easier it will become to use the same techniques in your own interactions.

23Work with people. Conflict resolution is an interpersonal skill that must be developed by interacting with people. Experience with people will help improve your understanding of interpersonal relationships. This will help you to better resolve conflicts as well as to avoid them in the first place.

24Books you may find useful: Isenhart, Myra and Spangle, Michael. Collaborative Approaches to Resolving Conflict. Sage Publications, 2000; Yankelovich, Daniel. The Magic of Dialogue: Transforming Conflict into Cooperation. Simon & Schuster, Inc., 1999; Mayer, Bernard. Beyond Neutrality: Confronting the Crisis to Conflict Resolution. John Wiley & Sons, Inc., 2004.

25

26

27Sharing Information

28Examine your experiences and determine if there is pertinent information you can share with the group. If there is, find an appropriate time to speak up. On every team you are a part of you provide not only a unique set of skills, but also unique experiences that may hold to the answer to a problem.

29Figure out the best way for you to actively engage in discussion. Help create an environment that is best for you and others to share their ideas. Identify teams and people with whom you are most comfortable to work. Learn to work with those individuals you are not as comfortable working with.

30Speak your opinion without stepping on other people's toes. Try to be constructively critical of ideas and build off of them.

31Share enough information to accomplish the goal, but don't overload people. If you can tell people are not retaining information then be more specific and less detailed.

32Resist the temptation to sit back. Force yourself to speak up at each meeting. Keep your focus on the main goal.

33

34

35Supporting Co-workers

36Inspiring and motivating others effectively requires that you be motivated as well. People will not respond well to being told to do something their boss is not willing to do. If you are not enthusiastic and don't challenge yourself, people will recognize this and their motivation will suffer.

37Focusing too heavily on your own tasks without considering others can cause you to seem uncommitted to the members of your team. It is important that your team feel valued or you will struggle with motivating them to reach their goals. This requires taking a regular and active interest in the work they are doing, including helping them address and overcome challenges and obstacles.

38Appeal to your audience. Think about what is important to the people you'll be talking to about the organization's vision. Are they people who will want to get down to the details? Or do they only have a minute to understand what you're talking about? Think about it and modify your pitch to what will be most effective.

39Make a conscious effort to check your plans against organizational goals and the overall vision. Keep checking the plans as they evolve to make sure they continue to support long-term organizational interests.

40Expand organizational contacts. Use informal contacts in other groups and departments to broaden your knowledge of organizational operations. Develop new contacts who can give you new insight into the company's goals and help you better understand how your work fits into the broader organizational strategy.

41Be positive, enthusiastic. Remember that your attitude and mood can affect others no matter what you are saying. Smile, be energetic when you speak, look people in the eye. The more enthusiastic you are about your ideas, the more committed others are likely to be in supporting you.

42Look at needs and wants. The key to managing and improving performance lies in understanding each employees' needs and wants and showing how their tasks and assignments relate to their personal career goals and desires. Simply taking time to sincerely talk with people about their job satisfaction, engagement, and career ambitions can help increase their sense of motivation.

43Share responsibility for all outcomes. If the outcome is good, share praise and rewards. If the outcome is bad, let individuals know what the consequences are and how they could improve their part in the future.

44Not everyone values the same rewards. Learn what motivates your people. Use a variety of methods to reward people including public recognition, financial incentives, work assignments that match their goals, or other ways to provide them with things they value. Don't promise more than you can deliver, but be creative in what you promise.

45Recognize achievements immediately. Don't delay rewarding hard work. Make sure that your appreciation is given while accomplishments are still fresh in someone's mind.

46Make your criticism constructive and actionable. When someone has made a mistake, don't talk to them before you've come up with at least one specific thing they can do to improve. Get in the habit of giving all employees specific incident-oriented criticism. Show the employee the steps to take to be successful, and show your interest in their success.

47Encourage staff to step up and set high standards for themselves. Make it clear that setting ambitious goals and reaching them is something that will be appreciated and rewarded in your organization.

48Books you may find useful: Staley, M.F. (1998). Igniting the Leader Within: Inspiring, Motivating, & Influencing Others. Saddle Brook: Fire Engineering Books & Videos; Nair, K. (1993). Leadership as Service. Audiobook: Stanford Alumni Association; Bruce, A., & Pepitone, J.S. (1999). Motivating Employees. New York: McGraw-Hill Companies, Inc.
Worksheet: Advise

[DocAElstein]

Notes in support of this thread:
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists
Following approximately these steps:
https://support.microsoft.com/en-us/office/create-a-drop-down-list-7693307a-59ef-400a-b769-c5402dce407b
Worksheets info from OP:
Requirements:

1. Under "Social Competencies", the drop down list should contain all the headers from the sheet "Comments" (Color Code - Peach).

2. Under "Please Choose", the drop down list should contain "Does Not Meet Expectation", "Meets Expectation", "Exceeds Expectation" (Color Code - Grey).

3. So, If a person selects "Communicating Effectively" under Social Competencies column, and then selects "Meets Expectation" in the next column, then the drop down list on Column D?? "Please Choose" should display the list from B3:B8 from the sheet named "Comments".

Another example would be if a person selects "Resolving Conflict" under Social Competencies column, and then selects "Does Not Meet Expectation" in the next column, then the drop down list on Column D "Please Choose" should display the list from A13:A18 from the sheet named "Comments".

4. So, If a person selects "Sharing Information" under Social Competencies column, then the drop down list on Column E "Give Advise" should display the list from A28:A32 from the sheet named "Give Advise"

( ?? typo – probably should be C)

See screenshots in last three posts for worksheets info
https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-etc-)-Event-Coding-Drpdown-Data-validation?p=15074&viewfull=1#post15074
https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-etc-)-Event-Coding-Drpdown-Data-validation?p=15074&viewfull=1#post15075
https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-etc-)-Event-Coding-Drpdown-Data-validation?p=15074&viewfull=1#post15076



I initially made some temporary ranges, -

_____ Workbook: Appraisal - Drop Down.xls ( Using Excel 2007 32 bit )
Row\ColDEFG
1

2Communicating Effectively

3Resolving Conflict

4Sharing Information

5Supporting Co-workers

6

7Does Not Meet ExpectationMeets ExpectationExceeds Expectation

8
Worksheet: Comments

I then ran a macro recording whilst following approximately the instructions here: https://support.microsoft.com/en-us/office/create-a-drop-down-list-7693307a-59ef-400a-b769-c5402dce407b

This is approximately what the macro recorder produced. ( I added Later some 'note comments )
Sub Macro2() ' https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-etc-)-Event-Coding-Drpdown-Data-validation?p=15077&viewfull=1#post15077
'In a new worksheet, type the entries you want to appear in your drop-down list. - I made some temporary ranges in second worksheet
Range("E2").Select
ActiveCell.FormulaR1C1 = "Communicating Effectively"
Range("E4").Select
ActiveCell.FormulaR1C1 = "Sharing Information"
Range("E5").Select
ActiveCell.FormulaR1C1 = "Supporting Co-workers"
Range("E6").Select
Range("A12:C12").Select
Selection.Copy
Range("E7").Select
ActiveSheet.Paste

Application.CutCopyMode = False

'Select the range in the worksheet where you want the drop down list
Range("A2:A8").Select
'Go to the Data tab on the Ribbon, then Data Validation. 'On the Settings tab, in the Allow box, click List. 'Click in the Source box, then select your list range. Click OK
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Comments!E2:E5"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With

Range("C2:C8").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Comments!E7:G7"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""

End Sub

[sandy666]

I see you're a famous writer ;)

[DocAElstein]

All my codings and postings are beautiful
I am a writer, and Artist also.

[DocAElstein]

Notes in support of this thread:
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists

Here are a few attempts at a macro , based on the macro produced from the macro recorder in the last post.

Sub MakeFirstTwoDropDowns1() '
With ThisWorkbook.Worksheets("Appraisal").Range("A2:A8").Validation
.Delete
'.Add Type:=xlValidateList, Formula1:="=Comments!E2:E5"
.Add Type:=xlValidateList, Formula1:="Communicating Effectively,Resolving Conflict,Sharing Information,Supporting Co - workers"
End With
With ThisWorkbook.Worksheets("Appraisal").Range("C2:C8").Validation
.Delete
'.Add Type:=xlValidateList, Formula1:="=Comments!E2:E5"
.Add Type:=xlValidateList, Formula1:="Does Not Meet Expectation,Meets Expectation,Exceeds Expectation"
End With
End Sub
Sub MakeFirstTwoDropDowns2()
Rem 1 worksheets info
Dim WsApp As Worksheet, WsComs As Worksheet
Set WsApp = ThisWorkbook.Worksheets("Appraisal"): Set WsComs = ThisWorkbook.Worksheets("Comments")
Rem 2 FirstTwoDropDowns2
WsApp.Range("A2:A8").Validation.Delete
'WsApp.Range("A2:A8").Validation.Add Type:=xlValidateList, Formula1:="Communicating Effectively,Resolving Conflict,Sharing Information,Supporting Co - workers"
WsApp.Range("A2:A8").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A1").Value & "," & WsComs.Range("A11").Value & "," & WsComs.Range("A21").Value & "," & WsComs.Range("A31").Value & ""

WsComs.Range("C2:C8").Validation.Delete
'WsComs.Range("C2:C8").Validation.Add Type:=xlValidateList, Formula1:="Does Not Meet Expectation,Meets Expectation,Exceeds Expectation"
WsComs.Range("C2:C8").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A2").Value & "," & WsComs.Range("B2").Value & "," & WsComs.Range("C2").Value & ""
End Sub

[DocAElstein]

AHDLadhlAHDAldhAH

[DocAElstein]

Macro for this post
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15085&viewfull=1#post15085

https://imgur.com/rteyeHM https://i.imgur.com/rteyeHM.jpg http://i.imgur.com/rteyeHM.jpg
https://i.imgur.com/rteyeHM.jpg

https://imgur.com/ex9FlRI https://i.imgur.com/ex9FlRI http://i.imgur.com/ex9FlRI
https://i.imgur.com/ex9FlRI.jpg

https://imgur.com/ZjEw5xy https://i.imgur.com/ZjEw5xy http://i.imgur.com/ZjEw5xy
https://i.imgur.com/ZjEw5xy.jpg



Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Rem 0 worksheets info
Dim WsAdv As Worksheet, WsComs As Worksheet
Set WsAdv = ThisWorkbook.Worksheets("Advise"): Set WsComs = ThisWorkbook.Worksheets("Comments")

Rem 1 Restrict most of the macro workings to only be done when specific ranges are chosen. In our case those ranges are column A and C
If Application.Intersect(Target, Me.Range("A2:A8,C2:C8")) Is Nothing Then
' do nothing because there was no intersection of the changed range, Target, and the cells of lists 1 and 2
Else
Rem 2
Dim RwTrgt As Long: Let RwTrgt = Target.Row
'2a_ -------------------------------------- Communicating effectively
If Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A1").Value Then ' Communicating Effectively
' create list 4 for case Communicating Effectively
Me.Range("E" & RwTrgt & "").Validation.Delete
Me.Range("E" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A2:A11"
' Now go through the 3 Choose Options for case Communicating Effectively
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A2").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 for case Communicating Effectively and Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A3:A8"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B2").Value Then ' Meets Expectation
'2a(ii) create list 3 for case Communicating Effectively and Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B3:B8"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C2").Value Then ' Exceeds Expectation
'2a(iii) create list 3 for case Communicating Effectively and Exceeds Expectation


End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation} for the case of Communicating effectively for Social Competencies
'_ --------------------------------------


'2b_ -------------------------------------- Resolving Conflict
ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A14").Value Then ' Resolving Conflict
' create list 4 for case Resolving Conflict

'_ --------------------------------------


'2c_ -------------------------------------- Sharing Information

ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A27").Value Then ' Sharing Information
' create list 4 for case Sharing Information

'_ --------------------------------------


'2d_ -------------------------------------- Supporting Co-workers

ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A35").Value Then ' Supporting Co-workers
' create list 4 for case Supporting Co-workers

'_ --------------------------------------

End If ' this is end of cases of social competencies


End If ' This is end of checking for selected range in columns A an C ( drop down lists 1 and 2 )

End Sub




https://i.imgur.com/bRPJELB.jpg

https://i.imgur.com/DHcaY0g.jpg





Summary of coding: ( Private Sub Worksheet_Change(ByVal Target As Range) -----
https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-etc-)-Event-Coding-Drpdown-Data-validation?p=15087&viewfull=1#post15087 )
Rem 1
We usually restrict most of the macro workings to only be done when specific ranges are chosen. In our case those ranges are column A and C from row 2 to row 8

Rem 2
In this section we go through the combinations of SOCIAL COMPETENCIES and Please Choose, and then create the appropriate drop down lists 3 and 4

‘2a) Communicating effectively
_... ‘2a(i) Does Not Meet Expectation
_... ‘2a(ii) Meets Expectation
_... ‘2a(iii) Exceeds Expectation

‘2b) Resolving Conflict
_... ‘2b(i) Does Not Meet Expectation
_... ‘2b(ii) Meets Expectation
_... ‘2b(iii) Exceeds Expectation

‘2c) Sharing Information
_... ‘2c(i) Does Not Meet Expectation
_... ‘2c(ii) Meets Expectation
_... ‘2c(iii) Exceeds Expectation

‘2d) Supporting Co-workers
_... ‘2d(i) Does Not Meet Expectation
_... ‘2d(ii) Meets Expectation
_... ‘2d(iii) Exceeds Expectation

[DocAElstein]

In support of this Thread post:
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15090&viewfull=1#post15090


First attempt by siyab.


Private Sub Worksheet_Change(ByVal Target As Range)
Rem 0 worksheets info
Dim WsAdv As Worksheet, WsComs As Worksheet
Set WsAdv = ThisWorkbook.Worksheets("Advise"): Set WsComs = ThisWorkbook.Worksheets("Comments")

Rem 1 Restrict most of the macro workings to only be done when specific ranges are chosen. In our case those ranges are column A and C
If Application.Intersect(Target, Me.Range("A2:A8,C2:C8")) Is Nothing Then
' do nothing because there was no intersection of the changed range, Target, and the cells of lists 1 and 2
Else
Rem 2
Dim RwTrgt As Long: Let RwTrgt = Target.Row
'2a_ -------------------------------------- Communicating effectively
If Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A1").Value Then ' Communicating Effectively
' create list 4 for case Communicating Effectively
Me.Range("E" & RwTrgt & "").Validation.Delete
Me.Range("E" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A2:A11"
' Now go through the 3 Choose Options for case Communicating Effectively
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A2").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 for case Communicating Effectively and Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A3:A8"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B2").Value Then ' Meets Expectation
'2a(ii) create list 3 for case Communicating Effectively and Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B3:B8"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C2").Value Then ' Exceeds Expectation
'2a(iii) create list 3 for case Communicating Effectively and Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C3:C8"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation} for the case of Communicating effectively for Social Competencies
'_ --------------------------------------


'2b_ -------------------------------------- Resolving Conflict
ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A14").Value Then ' Resolving Conflict
' create list 4 for case Resolving Conflict
Me.Range("E" & RwTrgt & "").Validation.Delete
Me.Range("E" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A15:A24"
' Now go through the 3 Choose Options for case Resolving Conflict
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A12").Value Then ' Does Not Meet Expectation
'2b(i) create list 3 for case Communicating Effectively and Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A13:A18"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B12").Value Then ' Meets Expectation
'2b(ii) create list 3 for case Communicating Effectively and Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B13:B18"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C12").Value Then ' Exceeds Expectation
'2b(iii) create list 3 for case Communicating Effectively and Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C13:C18"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation} for the case of Resolving Conflicts for Social Competencies
'_ --------------------------------------


'2c_ -------------------------------------- Sharing Information

ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A27").Value Then ' Sharing Information
' create list 4 for case Sharing Information
Me.Range("E" & RwTrgt & "").Validation.Delete
Me.Range("E" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A28:A32"
' Now go through the 3 Choose Options for case Sharing Information
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A22").Value Then ' Does Not Meet Expectation
'2c(i) create list 3 for case Communicating Effectively and Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A23:A28"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B22").Value Then ' Meets Expectation
'2c(ii) create list 3 for case Communicating Effectively and Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B23:B28"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C22").Value Then ' Exceeds Expectation
'2c(iii) create list 3 for case Communicating Effectively and Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C23:C28"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation} for the case of Sharing Information for Social Competencies
'_ --------------------------------------


'2d_ -------------------------------------- Supporting Co-workers

ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A35").Value Then ' Supporting Co-workers
' create list 4 for case Supporting Co-workers
Me.Range("E" & RwTrgt & "").Validation.Delete
Me.Range("E" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A36:A48"
' Now go through the 3 Choose Options for case Supporting Co-workers
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A32").Value Then ' Does Not Meet Expectation
'2d(i) create list 3 for case Communicating Effectively and Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A33:A38"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B32").Value Then ' Meets Expectation
'2d(ii) create list 3 for case Communicating Effectively and Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B33:B38"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C32").Value Then ' Exceeds Expectation
'2d(iii) create list 3 for case Communicating Effectively and Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C33:C38"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation} for the case of Supporting Co-workers for Social Competencies
'_ --------------------------------------
End If ' this is end of cases of social competencies
End If ' This is end of checking for selected range in columns A an C ( drop down lists 1 and 2 )
End Sub

[DocAElstein]

Some extra info for this Thread
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists




This is just some extra information, just out of passing interest.
You may be interested in adding another macro in the Appraisals worksheet object code module, a Private Sub Worksheet_SelectionChange(ByVal Target As Range) , :
https://imgur.com/BssuDnk , https://i.imgur.com/BssuDnk
https://i.imgur.com/BssuDnk.jpg

This macro will make the drop down lists appear in columns D an E when the cell is selected:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Rem 1 Restrict most of the macro workings to only be done when specific ranges are chosen. In our case those ranges are column A and C
If Application.Intersect(Target, Me.Range("D2:E8")) Is Nothing Then
' do nothing because there was no intersection of the changed range, Target, and the cells of lists 3 and 4
Else ' https://www.mrexcel.com/board/threads/auto-show-drop-down-list-when-selecting-the-cell.1144911/#post-5550521
Dim lDVType As XlDVType
If Target.Cells.CountLarge = 1 Then
On Error Resume Next
lDVType = Target.Validation.Type
On Error GoTo 0
If lDVType = xlValidateList Then SendKeys "%{down}"
End If
End If
End Sub


This macro will make the drop down lists appear in columns C and D an E when the cell is selected:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Rem 1 Restrict most of the macro workings to only be done when specific ranges are chosen. In our case those ranges are column A and C
If Application.Intersect(Target, Me.Range("C2:E8")) Is Nothing Then
' do nothing because there was no intersection of the changed range, Target, and the cells of lists 2 and 3 and 4
Else ' https://www.mrexcel.com/board/threads/auto-show-drop-down-list-when-selecting-the-cell.1144911/#post-5550521
Dim lDVType As XlDVType
If Target.Cells.CountLarge = 1 Then
On Error Resume Next
lDVType = Target.Validation.Type
On Error GoTo 0
If lDVType = xlValidateList Then SendKeys "%{down}"
End If
End If
End Sub


This macro will make the drop down lists for any cells appear when selecting the cell associated with the list.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Rem 1 Restrict most of the macro workings to only be done when specific ranges are chosen. In our case those ranges are column A and C
If Application.Intersect(Target, Me.Range("C2:E8")) Is Nothing Then
' do nothing because there was no intersection of the changed range, Target, and the cells of lists 2 and 3 and 4
Else ' https://www.mrexcel.com/board/threads/auto-show-drop-down-list-when-selecting-the-cell.1144911/#post-5550521
Dim lDVType As XlDVType
If Target.Cells.CountLarge = 1 Then
On Error Resume Next
lDVType = Target.Validation.Type
On Error GoTo 0
If lDVType = xlValidateList Then SendKeys "%{down}"
End If
End If

' .....Merged cells often cause difficulties with vba code. ..... https://www.mrexcel.com/board/threads/auto-show-drop-down-list-when-selecting-the-cell.1144911/#post-5550550
If Application.Intersect(Target, Me.Range("A2:B8")) Is Nothing Then
' do nothing because there was no intersection of the changed range, Target, and the cells of list 1
Else
If Target.Cells.CountLarge = 2 And Target.Rows.CountLarge = 1 Then
SendKeys "%{down}"
End If
End If




Ref
https://www.mrexcel.com/board/threads/auto-show-drop-down-list-when-selecting-the-cell.1144911/
https://excelfox.com/forum/showthread.php/2630-Auto-Show-Drop-Down-List-When-Selecting-the-Cell








Share ‘Appraisal - Automatic Drop Down.xls’ : https://app.box.com/s/wj11tpgc9fsuoekp023cd7ndkkqyvtm1

[DocAElstein]

In support of this Post
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15110#post15110


Sub MakeNormalDropDowns2x4() ' https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15110&viewfull=1#post15110
Rem 1 worksheets info
Dim WsApp As Worksheet, WsComs As Worksheet, WsActual As Worksheet
Set WsApp = ThisWorkbook.Worksheets("Appraisal"): Set WsComs = ThisWorkbook.Worksheets("Comments"): Set WsActual = ThisWorkbook.Worksheets("Actual Appraisal Form")

Rem FirstTwoDropDowns

Rem 2 SOCIAL COMPETENCIES
'2a) Topic SOCIAL COMPETENCIES List 1 in column A
WsActual.Range("A26:A27").Validation.Delete
WsActual.Range("A26:A27").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A1").Value & "," & WsComs.Range("A11").Value & "," & WsComs.Range("A21").Value & "," & WsComs.Range("A31").Value & ""

'2b) Please Choose List 2 in column C
WsActual.Range("C26:C27").Validation.Delete
WsActual.Range("C26:C27").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A2").Value & "," & WsComs.Range("B2").Value & "," & WsComs.Range("C2").Value & ""

Rem 3 PERSONAL COMPETENCIES
'3a) Topic PERSONAL COMPETENCIES List 1 in column A
WsActual.Range("A29:A30").Validation.Delete
WsActual.Range("A29:A30").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A41").Value & "," & WsComs.Range("A51").Value & "," & WsComs.Range("A61").Value & "," & WsComs.Range("A71").Value & "," & WsComs.Range("A81").Value & "," & WsComs.Range("A91").Value & ""

'3b) Please Choose List 2 in column C
WsActual.Range("C29:C30").Validation.Delete
WsActual.Range("C29:C30").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A2").Value & "," & WsComs.Range("B2").Value & "," & WsComs.Range("C2").Value & ""

Rem 4 METHODOLOGICAL COMPETENCIES
'4a) Topic METHODOLOGICAL COMPETENCIES List 1 in column A
WsActual.Range("A32:A33").Validation.Delete
WsActual.Range("A32:A33").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A111").Value & "," & WsComs.Range("A121").Value & "," & WsComs.Range("A131").Value & ""

'4b) Please Choose List 2 in column C
WsActual.Range("C32:C33").Validation.Delete
WsActual.Range("C32:C33").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A2").Value & "," & WsComs.Range("B2").Value & "," & WsComs.Range("C2").Value & ""

Rem 5 LEADERSHIP COMPETENCIES
'5a) Topic LEADERSHIP COMPETENCIES List 1 in column A
WsActual.Range("A35:A36").Validation.Delete
WsActual.Range("A35:A36").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A141").Value & "," & WsComs.Range("A151").Value & "," & WsComs.Range("A161").Value & "," & WsComs.Range("A171").Value & "," & WsComs.Range("A181").Value & "," & WsComs.Range("A191").Value & ""

'5b) Please Choose List 2 in column C
WsActual.Range("C35:C36").Validation.Delete
WsActual.Range("C35:C36").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A2").Value & "," & WsComs.Range("B2").Value & "," & WsComs.Range("C2").Value & ""


End Sub



Sub MakeNormalDropDowns1x4andLoop4times() ' https://excelfox.com/forum/showthread.php/2561-Appendix-Thread-(-Codes-for-other-Threads-etc-)-Event-Coding-Drpdown-Data-validation?p=15111&viewfull=1#post15111 https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15110&viewfull=1#post15110
Rem 1 worksheets info
Dim WsApp As Worksheet, WsComs As Worksheet, WsActual As Worksheet
Set WsApp = ThisWorkbook.Worksheets("Appraisal"): Set WsComs = ThisWorkbook.Worksheets("Comments"): Set WsActual = ThisWorkbook.Worksheets("Actual Appraisal Form")

Rem FirstTwoDropDowns

Rem 2 SOCIAL COMPETENCIES
'2a) Topic SOCIAL COMPETENCIES List 1 in column A
WsActual.Range("A26:A27").Validation.Delete
WsActual.Range("A26:A27").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A1").Value & "," & WsComs.Range("A11").Value & "," & WsComs.Range("A21").Value & "," & WsComs.Range("A31").Value & ""

Rem 3 PERSONAL COMPETENCIES
'3a) Topic PERSONAL COMPETENCIES List 1 in column A
WsActual.Range("A29:A30").Validation.Delete
WsActual.Range("A29:A30").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A41").Value & "," & WsComs.Range("A51").Value & "," & WsComs.Range("A61").Value & "," & WsComs.Range("A71").Value & "," & WsComs.Range("A81").Value & "," & WsComs.Range("A91").Value & ""

Rem 4 METHODOLOGICAL COMPETENCIES
'4a) Topic METHODOLOGICAL COMPETENCIES List 1 in column A
WsActual.Range("A32:A33").Validation.Delete
WsActual.Range("A32:A33").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A111").Value & "," & WsComs.Range("A121").Value & "," & WsComs.Range("A131").Value & ""

Rem 5 LEADERSHIP COMPETENCIES
'5a) Topic LEADERSHIP COMPETENCIES List 1 in column A
WsActual.Range("A35:A36").Validation.Delete
WsActual.Range("A35:A36").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A141").Value & "," & WsComs.Range("A151").Value & "," & WsComs.Range("A161").Value & "," & WsComs.Range("A171").Value & "," & WsComs.Range("A181").Value & "," & WsComs.Range("A191").Value & ""


Rem Please Choose - all 4 ranges in a loop
Dim Ofst As Long
For Ofst = 0 To 9 Step 3
WsActual.Range("C26:C27").Offset(RowOffset:=Ofst, ColumnOffset:=0).Validation.Delete
WsActual.Range("C26:C27").Offset(RowOffset:=Ofst, ColumnOffset:=0).Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A2").Value & "," & WsComs.Range("B2").Value & "," & WsComs.Range("C2").Value & ""
Next Ofst

End Sub





Share 'Appraisal - Drop Down 11 11.xls' : https://app.box.com/s/wj11tpgc9fsuoekp023cd7ndkkqyvtm1

[DocAElstein]

In support of this Thread
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15110#post15110

[DocAElstein]

Some extra notes in development of answer for this post
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15119&viewfull=1#post15119
( second complicated part: lists 3 and 4 based on choice from Lists 1 and 2 )


Private Sub Worksheet_Change(ByVal Target As Range)
Rem 1 worksheets info
Dim WsApp As Worksheet, WsComs As Worksheet, WsActual As Worksheet, WsAdv As Worksheet
Set WsAdv = ThisWorkbook.Worksheets("Advise"): Set WsApp = ThisWorkbook.Worksheets("Appraisal"): Set WsComs = ThisWorkbook.Worksheets("Comments"): Set WsActual = ThisWorkbook.Worksheets("Actual Appraisal Form")

Dim RwTrgt As Long: Let RwTrgt = Target.Row

' Rem 2 Rem 3 Rem 4 Rem5 Topics, determined by row selection in columns A and C -------------------------------------------
If Not Application.Intersect(Target, Me.Range("A26:A27,C26:C27")) Is Nothing Then ' Not nothing means we changed something in A26:A27 or C26:C27
Rem 2 Topic: SOCIAL COMPETENCIES

ElseIf Not Application.Intersect(Target, Me.Range("A29:A30,C29:C30")) Is Nothing Then
Rem 3 Topic: PERSONAL COMPETENCIES

ElseIf Not Application.Intersect(Target, Me.Range("A32:A33,C32:C33")) Is Nothing Then
Rem 4 Topic: METHODOLOGICAL COMPETENCIES

ElseIf Not Application.Intersect(Target, Me.Range("A35:A36,C35:C36")) Is Nothing Then
Rem 5 Topic: LEADERSHIP COMPETENCIES


Else '
' we come here if had changed something anywhere else other than ranges A26:A27,C26:C27, A29:A30,C29:C30, A32:A33,C32:C33, A35:A36,C35:C36
End If ' This is the end of all Topics
' Énd of all Topics ------------------------------------------------------------------------------------------------------
End Sub

[DocAElstein]

continued from last post - Some extra notes in development of answer for this post
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15119&viewfull=1#post15119
( second complicated part: lists 3 and 4 based on choice from Lists 1 and 2 )




Private Sub Worksheet_Change(ByVal Target As Range)
Rem 1 worksheets info
Dim WsApp As Worksheet, WsComs As Worksheet, WsActual As Worksheet, WsAdv As Worksheet
Set WsAdv = ThisWorkbook.Worksheets("Advise"): Set WsApp = ThisWorkbook.Worksheets("Appraisal"): Set WsComs = ThisWorkbook.Worksheets("Comments"): Set WsActual = ThisWorkbook.Worksheets("Actual Appraisal Form")

Dim RwTrgt As Long: Let RwTrgt = Target.Row

' Rem 2 Rem 3 Rem 4 Rem5 Topics, determined by row selection in columns A and C -------------------------------------------
If Not Application.Intersect(Target, Me.Range("A26:A27,C26:C27")) Is Nothing Then ' Not nothing means we changed something in A26:A27 or C26:C27
Rem 2 Topic: SOCIAL COMPETENCIES
'2a_ -------------------------------------- Communicating effectively
' create list 4 Advice
' Now go through the 3 Choose Options
'2a(i) create list 3 Does Not Meet Expectation
'2a(ii) create list 3 Meets Expectation
'2a(iii) create list 3 Exceeds Expectation
'2b_ -------------------------------------- Resolving Conflict
' create list 4 Advice
' Now go through the 3 Choose Options
'2b(i) create list 3 Does Not Meet Expectation
'2b(ii) create list 3 Meets Expectation
'2b(iii) create list 3 Exceeds Expectation
'2c_ -------------------------------------- Sharing Information
' create list 4 Advice
' Now go through the 3 Choose Options
'2c(i) create list 3 for case Does Not Meet Expectation
'2c(ii) create list 3 for case Meets Expectation
'2c(iii) create list 3 for case Exceeds Expectation
'2d_ -------------------------------------- Supporting Co-workers
' create list 4 Advice
' Now go through the 3 Choose Options
'2d(i) create list 3 for case Does Not Meet Expectation
'2d(ii) create list 3 for case Meets Expectation
'2d(iii) create list 3 for case Exceeds Expectation
' this is end of Topic social competencies

ElseIf Not Application.Intersect(Target, Me.Range("A29:A30,C29:C30")) Is Nothing Then
Rem 3 Topic: PERSONAL COMPETENCIES
'3a_ -------------------------------------- Adapting to Change
' create list 4 Advice
' Now go through the 3 Choose Options
'3a(i) create list 3 Does Not Meet Expectation
'3a(ii) create list 3 Meets Expectation
'3a(iii) create list 3 Exceeds Expectation
'3b_ -------------------------------------- Demonstrating Tenacity and Perseverance
' create list 4 Advice
' Now go through the 3 Choose Options
'3b(i) create list 3 Does Not Meet Expectation
'3b(ii) create list 3 Meets Expectation
'3b(iii) create list 3 Exceeds Expectation
'3c_ -------------------------------------- Following Policies and Procedures
' create list 4 Advice
' Now go through the 3 Choose Options
'3c(i) create list 3 for case Does Not Meet Expectation
'3c(ii) create list 3 for case Meets Expectation
'3c(iii) create list 3 for case Exceeds Expectation
'3d_ -------------------------------------- Learning Quickly
' create list 4 Advice
' Now go through the 3 Choose Options
'3d(i) create list 3 for case Does Not Meet Expectation
'3d(ii) create list 3 for case Meets Expectation
'3d(iii) create list 3 for case Exceeds Expectation
'3e_ -------------------------------------- Pursuing Self-Development

' create list 4 Advice
' Now go through the 3 Choose Options
'3e(i) create list 3 for case Does Not Meet Expectation
'3e(ii) create list 3 for case Meets Expectation
'3e(iii) create list 3 for case Exceeds Expectation
'3f_ -------------------------------------- Supporting Organizational Goals
' create list 4 Advice
' Now go through the 3 Choose Options
'3f(i) create list 3 for case Does Not Meet Expectation
'3f(ii) create list 3 for case Meets Expectation
'3f(iii) create list 3 for case Exceeds Expectation
' this is end of Topic PERSONAL COMPETENCIES

ElseIf Not Application.Intersect(Target, Me.Range("A32:A33,C32:C33")) Is Nothing Then
Rem 4 Topic: METHODOLOGICAL COMPETENCIES
'4a_ -------------------------------------- Evaluating and Implementing Ideas
' create list 4 Advice
' Now go through the 3 Choose Options
'4a(i) create list 3 Does Not Meet Expectation
'4a(ii) create list 3 Meets Expectation
'4a(iii) create list 3 Exceeds Expectation
'4b_ -------------------------------------- Managing Time
' create list 4 Advice
' Now go through the 3 Choose Options
'4b(i) create list 3 Does Not Meet Expectation
'4b(ii) create list 3 Meets Expectation
'4b(iii) create list 3 Exceeds Expectation
'4c_ -------------------------------------- Prioritizing and Organizing Work
' create list 4 Advice
' Now go through the 3 Choose Options
'4c(i) create list 3 for case Does Not Meet Expectation
'4c(ii) create list 3 for case Meets Expectation
'4c(iii) create list 3 for case Exceeds Expectation
'4d_ -------------------------------------- Solving Complex Problems
' create list 4 Advice
' Now go through the 3 Choose Options
'4d(i) create list 3 for case Does Not Meet Expectation
'4d(ii) create list 3 for case Meets Expectation
'4d(iii) create list 3 for case Exceeds Expectation
' this is end of Topic METHODOLOGICAL COMPETENCIES

ElseIf Not Application.Intersect(Target, Me.Range("A35:A36,C35:C36")) Is Nothing Then
Rem 5 Topic: LEADERSHIP COMPETENCIES
'5a_ -------------------------------------- Accepting Responsibility Acting Strategically ???????
' create list 4 Advice
' Now go through the 3 Choose Options
'5a(i) create list 3 Does Not Meet Expectation
'5a(ii) create list 3 Meets Expectation
'5a(iii) create list 3 Exceeds Expectation
'5b_ -------------------------------------- Delegating Responsibility
' create list 4 Advice
' Now go through the 3 Choose Options
'5b(i) create list 3 Does Not Meet Expectation
'5b(ii) create list 3 Meets Expectation
'5b(iii) create list 3 Exceeds Expectation
'5c_ -------------------------------------- Developing Talent
' create list 4 Advice
' Now go through the 3 Choose Options
'5c(i) create list 3 for case Does Not Meet Expectation
'5c(ii) create list 3 for case Meets Expectation
'5c(iii) create list 3 for case Exceeds Expectation
'5d_ -------------------------------------- Driving for Results

' create list 4 Advice
' Now go through the 3 Choose Options
'5d(i) create list 3 for case Does Not Meet Expectation
'5d(ii) create list 3 for case Meets Expectation
'5d(iii) create list 3 for case Exceeds Expectation
'5e_ -------------------------------------- Inspiring and Motivating Others
' create list 4 Advice
' Now go through the 3 Choose Options
'5e(i) create list 3 for case Does Not Meet Expectation
'5e(ii) create list 3 for case Meets Expectation
'5e(iii) create list 3 for case Exceeds Expectation
'5f_ -------------------------------------- Managing Performance
' create list 4 Advice
' Now go through the 3 Choose Options
'5f(i) create list 3 for case Does Not Meet Expectation
'5f(ii) create list 3 for case Meets Expectation
'5f(iii) create list 3 for case Exceeds Expectation
' this is end of Topic LEADERSHIP COMPETENCIES

Else '
' we come here if had changed something anywhere else other than ranges A26:A27,C26:C27, A29:A30,C29:C30, A32:A33,C32:C33, A35:A36,C35:C36
End If ' This is the end of all Topics
' Énd of all Topics ------------------------------------------------------------------------------------------------------
End Sub




At lot of the tedious typing can be simplifies by copy ( Ctrl+c ) and pasting ( Ctrl+v ) and sometimes further the modification can be done easier using tools such as Search and Replace on highlighted text
SearchReplaceInVBEditor.JPG
https://imgur.com/4Ou7Q6q https://i.imgur.com/4Ou7Q6q.jpg
https://i.imgur.com/4Ou7Q6q.jpg

Note: Make sure you select Highlighted text

SearchReplaceInVBEditorOnHighlightedText.JPG
https://imgur.com/Wvw7Ol1.jpg https://i.imgur.com/Wvw7Ol1.jpg
https://i.imgur.com/Wvw7Ol1.jpg

[DocAElstein]

continued from last post - Some extra notes in development of answer for this post
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15119&viewfull=1#post15119
( second complicated part: lists 3 and 4 based on choice from Lists 1 and 2 )





This was almost a direct copy from the previous macro for Rem 2
I only had to change all the
Me.Range("E" & RwTrgt & "")
to
Me.Range("G" & RwTrgt & "")

This change was necessary because the Advice range has moved from column E to column G



Private Sub Worksheet_Change(ByVal Target As Range)
Rem 1 worksheets info
Dim WsApp As Worksheet, WsComs As Worksheet, WsActual As Worksheet, WsAdv As Worksheet
Set WsAdv = ThisWorkbook.Worksheets("Advise"): Set WsApp = ThisWorkbook.Worksheets("Appraisal"): Set WsComs = ThisWorkbook.Worksheets("Comments"): Set WsActual = ThisWorkbook.Worksheets("Actual Appraisal Form")

Dim RwTrgt As Long: Let RwTrgt = Target.Row

' Rem 2 Rem 3 Rem 4 Rem5 Topics, determined by row selection in columns A and C -------------------------------------------
If Not Application.Intersect(Target, Me.Range("A26:A27,C26:C27")) Is Nothing Then ' Not nothing means we changed something in A26:A27 or C26:C27
Rem 2 Topic: SOCIAL COMPETENCIES
'2a_ -------------------------------------- Communicating effectively
If Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A1").Value Then
' create list 4 Advice
Me.Range("G" & RwTrgt & "").Validation.Delete
Me.Range("G" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A2:A11"
' Now go through the 3 Choose Options
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A2").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A3:A8"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B2").Value Then ' Meets Expectation
'2a(ii) create list 3 Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B3:B8"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C2").Value Then ' Exceeds Expectation
'2a(iii) create list 3 Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C3:C8"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation}



'2b_ -------------------------------------- Resolving Conflict
ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A14").Value Then
' create list 4 Advice
Me.Range("G" & RwTrgt & "").Validation.Delete
Me.Range("G" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A15:A24"
' Now go through the 3 Choose Options
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A12").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A13:A18"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B12").Value Then ' Meets Expectation
'2a(ii) create list 3 Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B13:B18"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C12").Value Then ' Exceeds Expectation
'2a(iii) create list 3 Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C13:C18"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation}



'2c_ -------------------------------------- Sharing Information

ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A27").Value Then ' Sharing Information
' create list 4 Advice
Me.Range("G" & RwTrgt & "").Validation.Delete
Me.Range("G" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A28:A32"
' Now go through the 3 Choose Options
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A22").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 for case Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A23:A28"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B22").Value Then ' Meets Expectation
'2a(ii) create list 3 for case Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B23:B28"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C22").Value Then ' Exceeds Expectation
'2a(iii) create list 3 for case Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C23:C28"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation}



'2d_ -------------------------------------- Supporting Co-workers

ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A35").Value Then ' Supporting Co-workers
' create list 4 Advice
Me.Range("G" & RwTrgt & "").Validation.Delete
Me.Range("G" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A36:A48"
' Now go through the 3 Choose Options
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A32").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 for case Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A33:A38"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B32").Value Then ' Meets Expectation
'2a(ii) create list 3 for case Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B33:B38"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C32").Value Then ' Exceeds Expectation
'2a(iii) create list 3 for case Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C33:C38"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation}

Else
End If
' this is end of cases of Topic social competencies

[DocAElstein]

continued from last post - Some extra notes in development of answer for this post
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15119&viewfull=1#post15119
( second complicated part: lists 3 and 4 based on choice from Lists 1 and 2 )





One small step further,
PERSONAL COMPETENCIES Adapting to Change
PERSONAL COMPETENCIES Adapting to Change.JPG
https://i.imgur.com/1Eu9oa4.jpg https://imgur.com/1Eu9oa4
https://i.imgur.com/wgdvdfy.jpg



Private Sub Worksheet_Change(ByVal Target As Range)
Rem 1 worksheets info
Dim WsApp As Worksheet, WsComs As Worksheet, WsActual As Worksheet, WsAdv As Worksheet
Set WsAdv = ThisWorkbook.Worksheets("Advise"): Set WsApp = ThisWorkbook.Worksheets("Appraisal"): Set WsComs = ThisWorkbook.Worksheets("Comments"): Set WsActual = ThisWorkbook.Worksheets("Actual Appraisal Form")

Dim RwTrgt As Long: Let RwTrgt = Target.Row

' Rem 2 Rem 3 Rem 4 Rem5 Topics, determined by row selection in columns A and C -------------------------------------------
If Not Application.Intersect(Target, Me.Range("A26:A27,C26:C27")) Is Nothing Then ' Not nothing means we changed something in A26:A27 or C26:C27
Rem 2 Topic: SOCIAL COMPETENCIES
'2a_ -------------------------------------- Communicating effectively
If Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A1").Value Then
' create list 4 Advice
Me.Range("G" & RwTrgt & "").Validation.Delete
Me.Range("G" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A2:A11"
' Now go through the 3 Choose Options
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A2").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A3:A8"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B2").Value Then ' Meets Expectation
'2a(ii) create list 3 Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B3:B8"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C2").Value Then ' Exceeds Expectation
'2a(iii) create list 3 Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C3:C8"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation}



'2b_ -------------------------------------- Resolving Conflict
ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A14").Value Then
' create list 4 Advice
Me.Range("G" & RwTrgt & "").Validation.Delete
Me.Range("G" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A15:A24"
' Now go through the 3 Choose Options
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A12").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A13:A18"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B12").Value Then ' Meets Expectation
'2a(ii) create list 3 Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B13:B18"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C12").Value Then ' Exceeds Expectation
'2a(iii) create list 3 Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C13:C18"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation}



'2c_ -------------------------------------- Sharing Information

ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A27").Value Then ' Sharing Information
' create list 4 Advice
Me.Range("G" & RwTrgt & "").Validation.Delete
Me.Range("G" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A28:A32"
' Now go through the 3 Choose Options
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A22").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 for case Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A23:A28"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B22").Value Then ' Meets Expectation
'2a(ii) create list 3 for case Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B23:B28"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C22").Value Then ' Exceeds Expectation
'2a(iii) create list 3 for case Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C23:C28"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation}



'2d_ -------------------------------------- Supporting Co-workers

ElseIf Me.Range("A" & RwTrgt & "").Value = WsAdv.Range("A35").Value Then ' Supporting Co-workers
' create list 4 Advice
Me.Range("G" & RwTrgt & "").Validation.Delete
Me.Range("G" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A36:A48"
' Now go through the 3 Choose Options
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A32").Value Then ' Does Not Meet Expectation
'2a(i) create list 3 for case Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A33:A38"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B32").Value Then ' Meets Expectation
'2a(ii) create list 3 for case Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B33:B38"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C32").Value Then ' Exceeds Expectation
'2a(iii) create list 3 for case Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C33:C38"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation}

Else
End If
' this is end of cases of Topic social competencies

ElseIf Not Application.Intersect(Target, Me.Range("A29:A30,C29:C30")) Is Nothing Then
Rem 3 Topic: PERSONAL COMPETENCIES
'3a_ -------------------------------------- Adapting to Change
' create list 4 Advice
Me.Range("G" & RwTrgt & "").Validation.Delete
Me.Range("G" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Advise!A52:A67"
' Now go through the 3 Choose Options
If Me.Range("C" & RwTrgt & "").Value = WsComs.Range("A32").Value Then ' Does Not Meet Expectation
'3a(i) create list 3 for case Does Not Meet Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!A43:A48"
ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("B32").Value Then ' Meets Expectation
'3a(ii) create list 3 for case Meets Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!B43:B48"

ElseIf Me.Range("C" & RwTrgt & "").Value = WsComs.Range("C32").Value Then ' Exceeds Expectation
'3a(iii) create list 3 for case Exceeds Expectation
Me.Range("D" & RwTrgt & "").Validation.Delete
Me.Range("D" & RwTrgt & "").Validation.Add Type:=xlValidateList, Formula1:="=Comments!C43:C48"

End If ' this is end of cases of {Does Not Meet Expectation, Meets Expectation, Exceeds Expectation}
'3b_ -------------------------------------- Demonstrating Tenacity and Perseverance
' create list 4 Advice

[DocAElstein]

In support of answer for this post
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15113#post15113
( second complicated part: lists 3 and 4 based on choice from Lists 1 and 2
https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15119&viewfull=1#post15119)





Here is the next macro for you:
Share ‘Code Appraisal - Drop Down 11 11 xls .txt’ : https://app.box.com/s/jd6mgsnd5mkwuidi2idrpf72a3d91xvq
Share ‘Appraisal - Drop Down 11 11.xls’ : https://app.box.com/s/vuggryhlalxu3qjeztkt2jby3wv9jzoj
https://pastebin.com/Avgsv1h6