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

[DocAElstein]

In support of these threads.
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page30#post12493


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


'
Sub CompareDriverFilesDeviceManagerInDoubleDriverAllLi st2()
Rem 0
If ActiveSheet.Name <> "DeviceManagerProperties" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDMP As Worksheet, WsDDA As Worksheet
Set WsDMP = Worksheets("DeviceManagerProperties"): Set WsDDA = Worksheets("DDAllBefore")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range
Dim CelVl As String: Let CelVl = SrchForCel.Value
If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\")
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DDAllBefore!F5:DDAllBefore!G670") ' WsDDA.Range("=F5:G670")
Dim FndCel As Range
Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DDAllBefore!F5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'Debug.Print FndCel.Value
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDMP.Activate: SrchForCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
WsDDA.Activate: FndCel.Select
Application.Wait (Now + TimeValue("00:00:01"))
Let FndCel.Font.ColorIndex = ClrIdx
Else ' No match was found - the thing in the cell in
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub

















For
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page30#post12492

[DocAElstein]

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

Note a new modification... for the case of when a cell in Device Manger is coloured ( indicating a match to drivers ) but the case when no match is found in DriverStore. We then need to make the underline which we are using as an indication for a match to drivers

Else ' No match was found - the thing in the cell in this worksheet is not in the other worksheet
If SrchForCel.Font.Color <> 0 Then Let SrchForCel.Font.Underline = True 'we need an extra check for if the cell is already coluoured indicating a match in drivers
End If



Sub CompareDriverFilesDeviceManagerInDriverStore2() '
Rem 0
If ActiveSheet.Name <> "DeviceManagerProperties" Then
MsgBox prompt:="Oops": Exit Sub
Else
End If
Rem 1 Worksheets info
Dim WsDMP As Worksheet, WsDrSt As Worksheet
Set WsDMP = Worksheets("DeviceManagerProperties"): Set WsDrSt = Worksheets("DriverStore")

Rem 2 Looking at each cell in the selection
' Random number between 3 and 56 to get color index for any matching file names (1 is black, 2 is white , up to 56 is other colors: 3 to 56 is like (0 to 53)+3 Rnd gives like 0-.99999 so (Int(Rnd*54))+3 is what we want
Dim ClrIdx As Long
Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3

Dim SrchForCel As Range
For Each SrchForCel In Selection ' Take each cell in selected range. Each should be a cell in DeviceManagerProperties
Dim CelVl As String: Let CelVl = SrchForCel.Value
If CelVl <> "" And Left(CelVl, 3) = "C:\" And InStr(4, CelVl, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
Dim FileNmeSrchFor As String
Let FileNmeSrchFor = Right(CelVl, (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))) ' Determine the file name as that looking from the right as many characters as (the total character number) - (the position looking from the right of a "\") --- the characters count left over after the subtraction is equal to the character length of the file name
Rem 3 We now should have a file name, so we look for it in worksheet DDAllBefore
Dim SrchRng As Range: Set SrchRng = Application.Range("=DriverStore!D5:DriverStore!F4437") '
Dim FndCel As Range: Set FndCel = SrchRng.Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!D5"), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndCel Is Nothing Then ' the range is set, so the file string has been found in a cell in DDAllBefore
Rem 4 we have two matching cells
'4a) but we might already have a match,
If SrchForCel.Font.Color <> 0 Then ' Extra things to do if we already found the cell value in drivers
Let ClrIdx = SrchForCel.Font.ColorIndex ' this will make the line below to colorthe text of this cell redundant but will ensure that we use the same color in the DriverStore worksheet rather than the randomly generated one
WsDMP.Activate: SrchForCel.Select
Let SrchForCel.Font.Underline = True
Else
End If
'Debug.Print FndCel.Value
Do While Not FndCel Is Nothing ' Start Find next loop ======
'4b) color matching file names in each worksheet, we do the unecerssary activating and selecting so we can see what is going in
WsDMP.Activate: SrchForCel.Select ' This worksheet will be colured
Application.Wait (Now + TimeValue("00:00:01"))
'Let SrchForCel.Characters(((InStrRev(CelVl, "\", -1, vbBinaryCompare)) + 1), (Len(CelVl)) - (InStrRev(CelVl, "\", -1, vbBinaryCompare))).Font.ColorIndex = ClrIdx
Let SrchForCel.Font.ColorIndex = ClrIdx
Let SrchForCel.Font.Italic = True

WsDrSt.Activate: FndCel.Select ' the other workseet
Application.Wait (Now + TimeValue("00:00:02"))
Let FndCel.Font.ColorIndex = ClrIdx
Set FndCel = Application.Range("=DriverStore!D" & FndCel.Row + 1 & ":DriverStore!F4437").Find(what:=FileNmeSrchFor, After:=Application.Range("=DriverStore!F4437"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) '
Loop ' End Find next loop =================================
Else ' No match was found - the thing in the cell in this worksheet is not in the other worksheet
If SrchForCel.Font.Color <> 0 Then Let SrchForCel.Font.Underline = True 'we need an extra check for if the cell is already coluoured indicating a match in drivers
End If
Else ' case no file path string in cell
End If
Next SrchForCel
End Sub

[DocAElstein]

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





Sub FileTypesHereInDeviceManagerPropertiesUndDriverSto reUnddrivers2() ' http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page39#post12659 http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page18#post12360
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D2:F264")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long, Els2 As Long
Dim Ddl3 As Long, Sys3 As Long, Bin3 As Long, Cpa3 As Long, Vp3 As Long, Els3 As Long
Rem 3 Looping
'Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range ' a single cell to use as a stear element in the For Next loop
For Each rngStr In Rng
' For RwCnt = 1 To UBound(arrFiles(), 1)
' For ClCnt = 1 To UBound(arrFiles(), 2)
'If arrFiles(RwCnt, ClCnt) = "" Then
If rngStr.Value = "" Then
' Empty cell, so do nothing
Else ' Time to look at cell value
'If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
If Left(rngStr.Value, 3) = "C:\" And InStr(4, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
' Get the extension
Dim Xtn As String
'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
Let Xtn = Mid(rngStr.Value, (InStr(4, rngStr.Value, ".", vbBinaryCompare) + 1))
Select Case UCase(Xtn)
Case "SYS"
Let Sys = Sys + 1
If rngStr.Font.Italic = True Then Let Sys2 = Sys2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Sys3 = Sys3 + 1
Case "DLL"
Let Ddl = Ddl + 1
If rngStr.Font.Italic = True Then Let Ddl2 = Ddl2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Ddl3 = Ddl3 + 1
Case "BIN"
Let Bin = Bin + 1
If rngStr.Font.Italic = True Then Let Bin2 = Bin2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Bin3 = Bin3 + 1
Case "CPA"
Let Cpa = Cpa + 1
If rngStr.Font.Italic = True Then Let Cpa2 = Cpa2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Cpa3 = Cpa3 + 1
Case "VP"
Let Vp = Vp + 1
If rngStr.Font.Italic = True Then Let Vp2 = Vp2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Vp3 = Vp3 + 1
Case Else
Debug.Print "Case Else " & rngStr.Value
Let Els = Els + 1
If rngStr.Font.Italic = True Then Let Els2 = Els2 + 1
If rngStr.Font.Underline = xlUnderlineStyleSingle Then Let Els3 = Els3 + 1
End Select
Else ' not a file path
End If
End If
' Next ClCnt
' Next RwCnt
Next rngStr
Rem 4 output

Debug.Print "sys " & Sys & " (" & Sys2 & ") [" & Sys3 & "]"
Debug.Print "dll " & Ddl & " (" & Ddl2 & ") [" & Ddl3 & "]"
Debug.Print "bin " & Bin & " (" & Bin2 & ") [" & Bin3 & "]"
Debug.Print "cpa " & Cpa & " (" & Cpa2 & ") [" & Cpa3 & "]"
Debug.Print "vp " & Vp & " (" & Vp2 & ") [" & Vp3 & "]"
Debug.Print "els " & Els & " (" & Els2 & ") [" & Els3 & "]"

Debug.Print "Totals " & Sys + Ddl + Bin + Cpa + Vp + Els & " (" & Sys2 + Ddl2 + Bin2 + Cpa2 + Vp2 + Els2 & ") [" & Sys3 + Ddl3 + Bin3 + Cpa3 + Vp3 + Els3 & "]"
End Sub

[DocAElstein]

In support of this Thread answer
http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646


Option Explicit
Sub DDAllEarlier_Marz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim WsDDD As Worksheet: Set WsDDD = Worksheets("DDAllEarlier_Marz17")
Dim RngDD As Range, rngDB As Range ' =ANZAHL2(B2:B550) 255 =ANZAHL2(D2:D550) 366
Set RngDD = WsDDD.Range("B2:B550"): Set rngDB = WsDDD.Range("D2:D550")
' take each cell in column B range and find it in column D, but find next if the text is already coloured
Dim Rng As Range
For Each Rng In RngDD '----------------------|
If Rng <> "" Then
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim FndRng As Range
Set FndRng = rngDB.Find(what:=Rng.Value, After:=rngDB.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not have already been found.
Do While Not FndRng Is Nothing ' ===
If FndRng.Font.Color = 0 Then ' case "virgin black" text
FndRng.Select
Let FndRng.Font.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

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

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

[DocAElstein]

In support of these posts
http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page40#post12669
http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646


' _ Marz 2020
Sub DeviceManagerPropertiesMarz172020() ' http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim WsDMP As Worksheet: Set WsDMP = Worksheets("DeviceManagerProperties")
Dim rngDMP1 As Range, rngDMP2 As Range ' B1:F550 G1:J550
Set rngDMP1 = WsDMP.Range("B5:F550"): Set rngDMP2 = WsDMP.Range("G5:J550")
' take each cell in range for original DMP and find it in range for new DMP but find next if the interior is already coloured
Dim Rng As Range
For Each Rng In rngDMP1 '----------------------|
If Rng <> "" Then
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
Dim FndRng As Range
Set FndRng = rngDMP2.Find(what:=Rng.Value, After:=rngDMP2.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
If Not FndRng Is Nothing Then ' we have a match that may or may not have already been found.
Do While Not FndRng Is Nothing ' ===
If FndRng.Interior.ColorIndex = -4142 Then ' case "virgin "white"" text
FndRng.Select
Let FndRng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))

Rng.Select
Let Rng.Interior.ColorIndex = ClrIdx
Application.Wait (Now + TimeValue("00:00:01"))
Set FndRng = Nothing ' This will force the Loop to end after a succesful match
Else ' The cell already has background color, so try again from next row
Set FndRng = WsDMP.Range("G" & FndRng.Row + 1 & ":J550").Find(what:=Rng.Value, After:=WsDMP.Range("J550"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) ' https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
End If
Loop ' looping for next match ======
Else ' no cell value match
End If
Else ' case rng has not text in it
End If
Next Rng '------------------------------------|

End Sub




ExplorerBefore DeviceManager Earlier and Marz17 2020.xlsm : https://app.box.com/s/gsgwwbqggel397ufnruegjyfst51p3g6

[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 these posts: http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12897&viewfull=1#post12897
https://excelfox.com/forum/showthread.php/2582-delete-entire-row-by-vbA
https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files

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

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

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

Usually, this alternative, would overcome problems:

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



Example

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

Before:-

_____ Workbook: Delete Rows.xls ( Using Excel 2007 32 bit )
Row\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]

test ...


test

skjfSKJHFkjhfKJSHFSKJHFskjhf

Different File Types used for simple values
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


Function to make an Excel files from a text file containing values and separators

XLFlNme is the Excel File name wanted for the new File
TxtFlNme is Text File name of an existing text file
valSep is the values separator used in the existing text file##
LineSep is the line separator used in thee existing text file##
Paf it the path to the files. ( I assume they are at the same place for the existing text file and the new Excel File )

The function is almost identical to the macro I did for you here: Code for Text File to Excelhttps://eileenslounge.com/viewtopic.php?p=269105#p269105
The function is here: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13717&viewfull=1#post13717

It is a function.
So you will need to call it with a test macro such as this:

' https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx
Sub Test_MakeXLFileusingvaluesInTextFile()
Dim Pf As String
Let Pf = ThisWorkbook.Path ' ' CHANGE TO SUIT
'let pf = "C:\Users\WolfieeeStyle\Desktop" ' CHANGE TO SUIT
Call MakeXLFileusingvaluesInTextFile(Pf, "sample2BEFORE..csv", "Test.xlsx", ",", vbCr & vbLf)
End Sub


I tested it using this text file: Share ‘sample2BEFORE..csv’ : https://app.box.com/s/a3o4irgofydb71e3o0c4aaxefg6dw3bi
NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT

Running the test macro results in an Excel File being made looking like this:

_____ Workbook: Test.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKL
1NSE1010106<12783AGTT

2NSE226<12783AGTT

3NSE173886<12783AGTT

4
Worksheet: Sheet1

[DocAElstein]

lKSHFLhlhfl

[DocAElstein]

Just testing links to Threads


( 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


Later


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

[DocAElstein]

In support of this thread answer
https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx


' https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx
'XLFlNme is the Excel File name wanted for the new File
'TxtFlNme is Text File name of an existing text file
'valSep is the values separator used in the existing text file
'LineSep is the line separator used in thee existing text file
'Paf it the path to the files. ( I assume they are at the same place for the existing text file and the new Excel File )

Function MakeXLFileusingvaluesInTextFile(ByVal Paf As String, ByVal TxtFlNme As String, ByVal XLFlNme As String, ByVal valSep As String, ByVal LineSep As String)

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 = Paf & Application.PathSeparator & TxtFlNme ' 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 Line Seperator
Dim arrRws() As String: Let arrRws() = Split(TotalFile, LineSep, -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...
' 2c) split first line to determine the Field(column) number
Dim arrClms() As String: Let arrClms() = Split(arrRws(0), valSep, -1, vbBinaryCompare)
Dim ClmCnt As Long: Let ClmCnt = UBound(arrClms()) + 1
' 2d) we can now make an array for all the rows, and columns
Dim arrOut() As String: ReDim arrOut(1 To RwCnt, 1 To ClmCnt)

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 a worksheet in a new file
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Paf & Application.PathSeparator & XLFlNme, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Workbooks("" & XLFlNme & "").Worksheets.Item(1).Range("A1").Resize(RwCnt, ClmCnt).Value = arrOut()

End Function

[DocAElstein]

In support of the answer to these forum Thread posts
https://www.excelforum.com/excel-programming-vba-macros/1319768-if-condition-met-then-put-the-remark-between-files.html
https://excelfox.com/forum/showthread.php/2433-vba-Copy-Paste-Conditional-to-put-remark-1-2-3-etc?p=14130&viewfull=1#post14130


' https://www.excelforum.com/excel-programming-vba-macros/1319768-if-condition-met-then-put-the-remark-between-files.html#post5353174
Sub karmapala()
'Dim arr() As Variant
Dim Wb1 As Workbook, Wb2 As Workbook, Sh1 As Worksheet, Sh2 As Worksheet
Set Wb1 = Workbooks("1.xls")
Set Sh1 = Wb1.Worksheets.Item(1) ' Wb1.Sheets("1-Sheet1")
Dim Rng As Range ' For main data range in 1.xls
' Set Rng = Sh1.Range("D2", Sh1.Range("D" & Rows.Count).End(xlUp)) ' This and the next line will error if macro.xlsm is active when the macro is run as Rows.Count will give a much larger number ( 1048576 ) than there are rows in a pre Excel 2007 worksheet ( .
' Set Rng = Sh1.Range(Sh1.Range("D2"), Sh1.Range("D" & Rows.Count).End(xlUp))'
Set Rng = Sh1.Range("D2", Sh1.Range("D" & Sh1.Rows.Count).End(xlUp))
Set Wb2 = Workbooks("macro.xlsm") ' Workbooks("Macro.xlsm")
Set Sh2 = Wb2.Worksheets.Item(1) ' Wb2.Sheets("Sheet1")
Dim X As Long
X = 0
Rem 2 In this section we build an array, arr(), of column I values to be ... match Column I of 1.xls with column B of macro.xlsm
Dim Cel As Range
For Each Cel In Rng
Dim arr() As Variant ' This will become the array of column I values to be ... match Column I of 1.xls with column B of macro.xlsm
If Cel.Value = Cel.Offset(0, 1).Value And Cel.Value <> Cel.Offset(0, 2).Value Then
' If column D of 1.xls is equal to Column E of 1.xls & column D of 1.xls is not equal to column F of 1.xls Then ...
ReDim Preserve arr(X)
arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm
X = X + 1 ' to make the array element for the next entry, should there be one
End If

'If Cel.Value <> Cel.Offset(0, 1) And Cel.Value = Cel.Offset(0, 2) Then
If Cel.Value = Cel.Offset(0, 2) And Cel.Value <> Cel.Offset(0, 1) Then ' ...
ReDim Preserve arr(X)
ReDim Preserve arr(X)
arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm
X = X + 1 ' to make the array element for the next entry, should there be one
End If
Next

If X = 0 Then Exit Sub

Rem 3 In this section we take each of the values in column I of 1.xls meeting the criteria - ... match Column I of 1.xls with column B of macro.xlsm
Dim El
For Each El In arr() ' arr take each value in column I meeting the criteria - and look for the match in a row in column B of macro.xlsm
Dim B As Range ' The matched cell in column B in macro.xlsm
Set B = Sh2.Range("B:B").Find(El, lookat:=xlWhole) ' Look for the matched cell in macro.xlsm
If Not B Is Nothing Then
Dim FirstAddress As String: FirstAddress = B.Address ' The first match address to check when the VBA .Find Methos starts again
Do
If B.Offset(0, 1).Value = "" Then
B.Offset(0, 1).Value = 1 ' row of match has remark 1 in column C
Else
B.End(xlToRight).Offset(0, 1).Value = B.End(xlToRight).Value + 1
End If
Set B = Sh2.Range("B:B").FindNext(B) ' Look for the Next matched cell in macro.xlsm
Loop While B.Address <> FirstAddress ' check when the VBA .Find Methos starts again
End If
Next

End Sub

[DocAElstein]

post to get the URL - for later use

[DocAElstein]

Solution1 fo this Thread
http://www.eileenslounge.com/viewtopic.php?p=270792#p270792


Sub VBAArrayTypeAlternativeToFilterInSegs_Solution1() ' http://www.eileenslounge.com/viewtopic.php?p=270915#p270915 .......... https://eileenslounge.com/viewtopic.php?p=245238#p245238
Rem Make the two row indicie lists ( string of row indicies seperated witha space )
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Debug.Print strSuc
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1 ': Debug.Print strRws(Cnt - 1)
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
Let Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
' ================================================== ===
Rem Part B)
' Header
Worksheets("TempSht").Range("A7:X7").Copy
Worksheets("consultant doctor").Range("A7:X7").PasteSpecial Paste:=xlPasteAll ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' All formats in one go for each segmant from the temporary blue print worksheet
Worksheets("TempSht").Range("A8:X41").Copy
Worksheets("consultant doctor").Range("A8:X" & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 & "").PasteSpecial Paste:=xlPasteFormats '
' Formulas
Worksheets("TempSht").Range("A35:X41").Copy
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).PasteSpecial Paste:=xlFormulas ' Value = Worksheets("TempSht").Range("A35:X41").Formula
' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard
Next Cnt
' Sorting
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False
Next Cnt

'With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
'' Let .Value = arrOut()
'.Sort key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
'.Font.Name = "Times New Roman"
'.Font.Size = 13
'.Columns("D:X").NumberFormat = "0.00"
'.EntireColumn.AutoFit
'End With

''Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
' Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
' For Cnt = 1 To UBound(strRws(), 1) + 1
' Let Rws(Cnt, 1) = strRws(Cnt - 1)
' Next Cnt
' Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
'With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
'Let .Value = arrOut()
''.Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
'.Font.Name = "Times New Roman"
'.Font.Size = 13
'.Columns("D:X").NumberFormat = "0.00"
'.EntireColumn.AutoFit
'End With
End Sub

[DocAElstein]

post to get the URL - for later use

[DocAElstein]

Solution for this post:
https://eileenslounge.com/viewtopic.php?p=271047#p271047
https://eileenslounge.com/viewtopic.php?p=271137#p271137

The main thing is
Sub DropItIn()

The first macro, Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() , which is the one that you run, is almost identical to the very first unmodified macro, Sub VBAArrayTypeAlternativeToFilter() ' https://eileenslounge.com/viewtopic.php?p=270792#p270792




Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() ' https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
' First output worksheet
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
Let .Value = arrOut()
.Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
.Borders.LineStyle = xlContinuous
End With
' Adding extra rows and stuff for Worksheets("consultant doctor") ================
' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
Call DropItIn(Worksheets("consultant doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
' second output worksheet
'Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
Let .Value = arrOut()
.Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
.Borders.LineStyle = xlContinuous
End With
' Adding extra rows and stuff for Worksheets("Specialist Doctor") ==================
' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
Call DropItIn(Worksheets("Specialist Doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted

End Sub

[DocAElstein]

Macros for Solution 3 in this Thread here
https://eileenslounge.com/viewtopic.php?f=30&t=34878
Post
https://eileenslounge.com/viewtopic.php?p=271150#p271150



Sub Solution3_2Workbooks() '
Rem 1 Worksheets info
Dim WbM As Workbook, WbData As Workbook
Set WbM = ThisWorkbook: Set WbData = Workbooks("Example.xlsx")
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = WbData.Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
' First output worksheet
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
With WbData.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
Let .Value = arrOut()
.Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
.Borders.LineStyle = xlContinuous
End With
' Adding extra rows and stuff for Worksheets("consultant doctor") ================
' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
Call DropItIn3(WbData.Worksheets("consultant doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
' second output worksheet
'Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
With WbData.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
Let .Value = arrOut()
.Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
.Borders.LineStyle = xlContinuous
End With
' Adding extra rows and stuff for Worksheets("Specialist Doctor") ==================
' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
Call DropItIn3(WbData.Worksheets("Specialist Doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted

End Sub



' Call ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
'Worksheets("consultant doctor"), UBound(strRws(), 1) + 1 , 8 , 34 27, 7
' 88 , 8 , 34 , 27 , 7
Sub DropItIn3(Ws As Worksheet, RwsCnt As Long, SttRw As Long, FstBkRw As Long, DtaRws As Long, ExtRws As Long) ' https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047
' Header
ThisWorkbook.Worksheets("TempSht").Range("A7:X7").Copy
Ws.Range("A" & SttRw - 1 & ":X" & SttRw - 1 & "").PasteSpecial Paste:=xlPasteFormats ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' Insert extra rows
' Worksheets("TempSht").Range("A35:X41").Copy
Dim Cnt As Long
' For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) - (DtaRws + ExtRws) Step DtaRws + ExtRws ' This misses the last section
For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) Step DtaRws + ExtRws
ThisWorkbook.Worksheets("TempSht").Range("A35:X41").Copy
Ws.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Insert shift:=xlShiftDown ' Value = Worksheets("TempSht").Range("A35:X41").Formula
' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard
Next Cnt

End Sub

[DocAElstein]

Macro for solution 4 for this Thread here
https://eileenslounge.com/viewtopic.php?f=30&t=34878
Post
https://eileenslounge.com/viewtopic.php?p=271181&sid=2753bfc8a84fd45abec5487d975c9974#p271181


Sub VBAArrayTypeAlternativeToFilterSolution4() ' BY M. Doc.AElstein .......... https://eileenslounge.com/viewtopic.php?p=245238#p245238
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
Debug.Print strSuc
' First output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), Clms())
Let Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
Rem Part B)
' Header
Worksheets("TempSht").Range("A7:X7").Copy
Worksheets("consultant doctor").Range("A7:X7").PasteSpecial Paste:=xlPasteAll ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' All formats in one go for each segmant from the temporary blue print worksheet
Worksheets("TempSht").Range("A8:X41").Copy
Worksheets("consultant doctor").Range("A8:X" & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 & "").PasteSpecial Paste:=xlPasteFormats '
' Formulas
Worksheets("TempSht").Range("A35:X41").Copy
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).PasteSpecial Paste:=xlFormulas ' Value = Worksheets("TempSht").Range("A35:X41").Formula
' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard
Next Cnt
''' Sorting NO LONGER NEEDED
'' For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
'' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False
'' Next Cnt

' With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
' Let .Value = arrOut()
' .Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
' .Font.Name = "Times New Roman"
' .Font.Size = 13
' .Columns("D:X").NumberFormat = "0.00"
' .EntireColumn.AutoFit
' End With
'' second output worksheet
''Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
' For Cnt = 1 To UBound(strRws(), 1) + 1
' Let Rws(Cnt, 1) = strRws(Cnt - 1)
' Next Cnt
' Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), Clms())
' With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
' Let .Value = arrOut()
' .Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
' .Font.Name = "Times New Roman"
' .Font.Size = 13
' .Columns("D:X").NumberFormat = "0.00"
' .EntireColumn.AutoFit
' End With
End Sub

[DocAElstein]

Notes in support of this Thread
https://excelfox.com/forum/showthread.php/2569-Copy-row-from-one-workbook-to-another-workbook-based-on-conditions-in-two-other-workbooks

_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHI
1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEADANIENTEQ151.85165.45151.4151.85152.3525

3NSEAMARAJABATEQ662.5665.9642.55662.5643.5100
Worksheet: 1-Sheet1 6July

_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZ
1UserIdAccountIdEntityNameExchg-SegSymbolInstrument NameOption TypeNetBuyValueNetSellValueNetValueNetBuyQtyNetSel lQtyNetQtyBEPSellAvgPriceBuyAvgPriceLastTradedPric eMarkToMarketRealized MarkToMarketUnrealized MarkToMarketEL MarkToMarketTrading SymbolClient ContextSeries/ExpiryStrike Price

2WC5758NSEAMBUJACEMEQ 10781.1010878.3097.205454201.45199.6520197.297.297 .2AMBUJACEM-EQEQ

3WC5758NSEADANIENTEQ 420.60430.509.9022215.25210.30210.359.99.99.9ADANI ENT-EQEQ25

4WC5758NSESIEMENSEQ 2609.302642.5033.20221321.251304.651322.733.233.23 3.2SIEMENS-EQEQ

5WC5758NSERBLBANKEQ 502.10530.3028.2022265.15251.05249.7528.228.228.2R BLBANK-EQEQ

6WC5758NSENATIONALUMEQ 1768.501782.0013.50545433.0032.7532.7513.513.513.5 NATIONALUM-EQEQ

7WC5758NSEMARICOEQ 1688.401713.0024.6066285.50281.40281.924.624.624.6 MARICO-EQEQ

8WC5758NSEAMARAJABATEQ 2429.102405.70-23.4018133.65134.95135-23.4-23.4-23.4APOLLOTYRE-EQEQ100

9WC5758NSEL&TFHEQ 1765.801794.6028.80181899.7098.1098.2528.828.828.8 L&TFH-EQEQ

10WC5758NSEITCEQ 360.90366.105.2022183.05180.45180.855.25.25.2ITC-EQEQ

11WC5758NSEINFRATELEQ 10988.0011180.70192.705454207.05203.48203.8192.719 2.7192.7INFRATEL-EQEQ

12WC5758NSEDLFEQ 93069.0094283.001214.00486486194.00191.50190.31214 12141214DLF-EQEQ
Worksheet: ap-Sheet1 6July

If column I of 1.xls matches with column Z of ap.xls & column K of ap.xls is equals to column L of ap.xls Then
Look column H of 1.xls & if column H of 1.xls is greater than column D of 1.xls then it has to copy the first row of OrderFormat.xlsx & paste it to BasketOrder.xlsx
If column I of 1.xls matches with column Z of ap.xls & column K of ap.xls is equals to column L of ap.xls Then
Look column H of 1.xls & if column H of 1.xls is lower than column D of 1.xls then it has to copy the third row of OrderFormat.xlsx & paste it to BasketOrder.xlsx

_____ Workbook: OrderFormat.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTU
1NSEEQNANANA00BUYMARKETNACLIMISDAYWC5758NA3NA

2NSEEQNANANA00SELLSL-MCLIMISDAYWC5758NANANA

3NSEEQNANANA00SELLMARKETNACLIMISDAYWC5758NA3NA

4NSEEQNANANA00BUYSL-MCLIMISDAYWC5758NANANA
Worksheet: Sheet1

Given BasketOrder
_____ Workbook: BasketOrder.xlsx Given by Avinash ( 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

1NSEEQNANANA
0
0BUYMARKETNACLIMISDAYWC5758NA
3NA
Worksheet: Sheet1 6July

For I of 25 in row 2 of 1.xls, we match with column z / row 3 in ap.xls
Column K and column L in ap.xls are both = 2 in row 3 in ap.xls So column K of ap.xls is equals to column L of ap.xls
Column H of row 2 in 1.xls is greater than column D of row 2 of 1.xls , so we copy the first row of of OrderFormat.xlsx & paste it to BasketOrder.xlsx
So I assume / geuss the given workbook, BasketOrder.xlsx is for After

[DocAElstein]

Macro solution for this post:
https://excelfox.com/forum/showthread.php/2569-Copy-row-from-one-workbook-to-another-workbook-based-on-conditions-in-two-other-workbooks


' https://excelfox.com/forum/showthread.php/2569-Copy-row-from-one-workbook-to-another-workbook-based-on-conditions-in-two-other-workbooks
' Copy row from one workbook to another workbook based on conditions in two other workbooks
Sub CopyRowFromWb4ToWb3basedOnConditionsInWb1AndWb2()
Rem 1 worksheets range info
Dim Wb1 As Workbook, Wb2 As Workbook, Wb3 As Workbook, Wb4 As Workbook
Set Wb1 = Workbooks("1.xls")
Set Wb2 = Workbooks("ap.xls")
Set Wb3 = Workbooks("BasketOrder.xlsx")
Set Wb4 = Workbooks("OrderFormat.xlsx")
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet, Ws4 As Worksheet
Set Ws1 = Wb1.Worksheets.Item(1)
Set Ws2 = Wb2.Worksheets.Item(1)
Set Ws3 = Wb3.Worksheets.Item(1)
Set Ws4 = Wb4.Worksheets.Item(1)
Dim Lr1 As Long, Lr2 As Long, Lr3 As Long ', Lr4 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Let Lr2 = Ws2.Range("D" & Ws2.Rows.Count & "").End(xlUp).Row
Dim Rng1 As Range, Rng2 As Range ', Rng3 As Range, Rng4 As Range
Set Rng1 = Ws1.Range("A1:I" & Lr1 & "")
Set Rng2 = Ws2.Range("A1:Z" & Lr2 & "")
'1b) data ranges for conditions
Dim arr1() As Variant: Let arr1() = Rng1.Value2
Dim arr1I() As Variant: Let arr1I() = Rng1.Columns(9).Value2
Dim arr2() As Variant: Let arr2() = Rng2.Value2
Dim arr2Z() As Variant: Let arr2Z() = Rng2.Columns("Z").Value2
Rem 2 Do it
Dim Cnt
For Cnt = 2 To Lr1 Step 1
If arr1I(Cnt, 1) <> "" Then
Dim MtchRes As Variant
Let MtchRes = Application.Match(arr1I(Cnt, 1), arr2Z(), 0)
If IsError(MtchRes) Then
' column I 1.xls value is not in column Z of ap.xls
Else ' column I of 1.xls matches with column Z of ap.xls
' if column K of ap.xls is equals to column L of ap.xls
If arr2(MtchRes, 11) = arr2(MtchRes, 12) Then
' If column H of 1.xls is greater than column D of 1.xls then
If arr1(Cnt, 8) > arr1(Cnt, 4) Then
'copy the first row of OrderFormat.xlsx & paste it to BasketOrder.xlsx
Let Ws3.Range("A1:U1").Value2 = Ws4.Range("A1:U1").Value2
ElseIf arr1(Cnt, 8) < arr1(Cnt, 4) Then ' If column H of 1.xls is less than column D of 1.xls then
'copy the third row of OrderFormat.xlsx & pate it to BasketOrder.xlsx
Else
Let Ws3.Range("A1:U1").Value2 = Ws4.Range("A3:U3").Value2
End If
Else
' column K of ap.xls is not equal to column L of ap.xls
End If
End If
Else
' empty column I in 1.xls
End If
Next Cnt
End Sub

[DocAElstein]

Macro for this post
https://eileenslounge.com/viewtopic.php?f=30&t=34878&p=271237#p271237
https://eileenslounge.com/viewtopic.php?p=271255#p271255


' https://eileenslounge.com/viewtopic.php?f=30&t=34878&p=271237#p271237
Sub Solution5() ' https://eileenslounge.com/viewtopic.php?f=30&t=34878&p=271237#p271237
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
' First half ##
' First output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(27, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
Next Cnt

' First half##
' Second output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(27, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
Next Cnt

End Sub

[DocAElstein]

Noptes in support of answer for this Post:
https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591


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

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTPWrong results


2NSEACCEQ
1265
1282.7
1246.5
1275.3
1247
22BUY
202<--Ws1


3NSEADANIENTEQ
151.85
165.45
151.4
151.85
152.35
25BUY
303


4NSEADANIPORTSEQ
348
348
338.5
346.55
338.85
15083BUY
0


5


6output wanted in K of 1.xls which is Ws1DEFGHIJKL


7
1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTPwanted results


8
2NSEACCEQ
1265
1282.7
1246.5
1275.3
1247
22BUY
101


9
3NSEADANIENTEQ
151.85
165.45
151.4
151.85
152.35
25BUY
202


10
4NSEADANIPORTSEQ
348
348
338.5
346.55
338.85
15083BUY
303


11
5


12


13


14


15Ws2 - AlertCodes.xlsxBCDEFGHIJKL


16
1NSE
22
6<
100AGTT


17
2NSE
25
6<
200AGTT


18
3NSE
15083
6<
300AGTT


19
4
Worksheet: 1-Sheet1 13July

[DocAElstein]

Macro for last post, and also for anser to this Thread post:
https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578
https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591
https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html
https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14588&viewfull=1#post14588
https://eileenslounge.com/viewtopic.php?f=30&t=34936



' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks/page4#post14578 https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578
' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591
Sub STEP6()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim Wb1 As Workbook, Wb2 As Workbook
Dim R2 As Long, Lr As Long, I As Long ' r2&, lr&, i&

Set Wb1 = Workbooks("1.xls") ' For open workbook Alternatively to open worknok - Examples: Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Set Wb2 = Workbooks("AlertCodes.xlsx") ' Workbooks.Open(ThisWorkbook.Path & "\AlertCodes.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Files\AlertCodes.xl sx")
Set Ws2 = Wb2.Worksheets.Item(4)
With Ws1
Let Lr = .Cells(.Rows.Count, "A").End(xlUp).Row
For I = 2 To Lr
' Reset r2
R2 = 0
' Avoid error messages
On Error Resume Next
' Try to get r2
R2 = WorksheetFunction.Match(.Cells(I, "I"), Ws2.[B:B], 0) ' R2 returns the matched row if there is a match
' Restore error handling
On Error GoTo 0
' Only set column K if r2 is valid
If R2 > 0 Then
If Ws2.Cells(R2, "D") = ">" Then
.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value - 0.01 * Ws2.Cells(R2, "E").Value ' Ws2.Cells(I, "E").Value - 0.01 * Ws2.Cells(I, "E").Value
Else
.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value + 0.01 * Ws2.Cells(R2, "E").Value ' Ws2.Cells(I, "E").Value + 0.01 * Ws2.Cells(I, "E").Value
End If
End If
Next I
End With
Wb1.Save
Wb1.Close
Wb2.Close

End Sub

[DocAElstein]

test post to get URL for later use

[DocAElstein]

Alternative solution to Step6()
( https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14595&viewfull=1#post14595
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14594&viewfull=1#post14594 )



The main changes are
_1) I use arrays. ( arr1() , arr2() , arr2B() )
I do this just from personal choice. I do this because arrays work much faster if you are only interested in values with no cell formatting
_2) I changed WorksheetFunction.Match to Application.Match , because I do not like to use On Error Resume Next
I do not need On Error Resume Next for Application.Match , because , if it does not find a match, it does not error. Instead, it returns a VBA error string message, which can be tested for using IsError( __ )
_2) I do not use _ With _ End With _ because it confuses me

I left the original code lines in , ' commented out for comparison




' https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html#post5342720 https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html#post5342598
' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks/page4#post14578 https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578
' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591
Sub STEP6Alternative()
Rem 1 Worksheets data info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Dim I As Long, Lr As Long ' R2 As Long, Lr As Long, I As Long ' r2&, lr&, i&
Set Wb1 = Workbooks("1.xls") ' For open workbook Alternatively to open workbook - Examples: Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Set Wb2 = Workbooks("AlertCodes.xlsx") ' Workbooks.Open(ThisWorkbook.Path & "\AlertCodes.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Files\AlertCodes.xl sx")
Set Ws2 = Wb2.Worksheets.Item(4)
' With Ws1
Let Lr = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
Dim arr1() As Variant
Let arr1() = Ws1.Range("A1:K" & Lr & "").Value2
Dim lr2 As Long ' https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=14565&viewfull=1#post14565 Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
Let lr2 = Ws2.Cells(Ws2.Rows.Count, "B").End(xlUp).Row ' This is the column to be serached in
Dim arr2B() As Variant
Let arr2B() = Ws2.Range("B1:B" & lr2 & "").Value2
Dim arr2() As Variant
Let arr2() = Ws2.Range("A1:K" & lr2 & "").Value2
Rem We consider the data values in column I of 1.xls ( first worksheet) , starting from row 2.
For I = 2 To Lr ' We consider the data values in column I of 1.xls ( first worksheet) , starting from row 2.
' Reset r2 R2 = 0 ' Avoid error messages On Error Resume Next
' Try to get r2 Values in column I of 1.xls ( first worksheet), starting at row 2, are to be looked for, ( Matched ) in column B of AlertCodes.xlsx ( 4th worksheet )
'R2 = WorksheetFunction.Match(.Cells(I, "I"), Ws2.[B:B], 0) ' R2 returns the matched row if there is a match
Dim R2 As Variant ' We need a variant so that both a Long Number or a VB error can be held in it, which are the two possible return types with Application.Match https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14204&viewfull=1#post14204
Let R2 = Application.Match(arr1(I, 9), arr2B(), 0) ' Ws1.Cells(I, "I").Value is arr1(I, 9) ' Restore error handling On Error GoTo 0
' Only set column K if r2 is valid, so only if a match was found, so only if R" is Not a VBA error
If Not IsError(R2) Then ' If R2 > 0 Then
'If Ws2.Cells(R2, "D") = ">" Then ' Ws2.Cells(R2, "D").Value is arr2(R2, 4)
If arr2(R2, 4) = ">" Then
' Ws1.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value - 0.01 * Ws2.Cells(R2, "E").Value ' This was wrong: Ws2.Cells(I, "E").Value - 0.01 * Ws2.Cells(I, "E").Value
arr1(I, 11) = arr2(R2, 5) - 0.01 * arr2(R2, 5)
'Else
ElseIf arr2(R2, 4) = "<" Then
' Ws1.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value + 0.01 * Ws2.Cells(R2, "E").Value ' This was wrong: Ws2.Cells(I, "E").Value + 0.01 * Ws2.Cells(I, "E").Value
arr1(I, 11) = arr2(R2, 5) + 0.01 * arr2(R2, 5)
Else
' we dont have a "<" or a ">" Do Nothing
End If
End If
Next I
' End With
'Rem Option to save and/ or close files
Wb1.Save
Wb1.Close
Wb2.Close
End Sub

[DocAElstein]

Full macro versions for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic.php?p=271960#p271960



Sub Ha2a() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row ' Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2 ' The only data needed to ba considered is column A. The "magic code line" will be used to get all our results in one go I need +1 to use an empty line in determining when the last name in the list has something different after it ##
Rem 2 Outer loop Do ing While data is still there in column A
Dim CntIn As Long: Let CntIn = 1 ' This will be for counting as We go down rows in column A
Do ' ================================================== ======== Main Outel loop for unique name section==
Rem 3 Inner Loop for a section of names ' ---------------------------------------------------------------
Dim strRws As String: Let strRws = "1" ' We are building a string of our required row indicia for a unique name. The first row , the header, will always be needed
Do
'3a) get the row indicies for this section
Let CntIn = CntIn + 1
Let strRws = strRws & " " & CntIn
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) ' this means we are not yet at the end of a section ---
'3b) start doing stuff for each unique name
'3b(i) The workbook with unique name
Workbooks.Add
Dim WbNme As String: Let WbNme = arrA(CntIn, 1) & ".xlsx" ' The current last unique name will be the new Workbook name
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)
'3b(ii) The "vertical" array of row indicies required for "magic code line"
Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) ' I can make a 1 Dimesional pseudo "horizontal" array easilly, from which the "horizontal array, RwsT() can be made
Dim RwsT() As String ' I must make this a dynamic array, even though I know the dimensions, because the Dim statement will only take hard coded numbers, wheras the ReDim method below allows us to make the sizing dynamic based on the size of Rws()
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) ' The +1 comes in because the Split function returns a 1D array starting at indicia 0
Dim Cnt As Long
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
'3b(iii) The "magic code line"
Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation
'3b(iv) Output to first worksheet in workbook and close and save it
Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
Workbooks(WbNme).Close Savechanges:=True
'3b(v) Some tidying up before we possibly go to the next unique name
Let strRws = "1" ' we must reset this, or else we will still have row indicies in it from the last unique name
Loop While CntIn < Lr
' ================================================== ================================================== ===


End Sub
' Simplified version
Sub Ha2a_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2
Dim CntIn As Long: Let CntIn = 1
Do
Dim strRws As String: Let strRws = "1"
Do
Let CntIn = CntIn + 1
Let strRws = strRws & " " & CntIn
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1)
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx"
Dim Rws() As String: Let Rws() = Split(strRws)
Dim RwsT() As String
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1)
Dim Cnt As Long
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
Let Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True
Let strRws = "1"
Loop While CntIn < Lr
End Sub


Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic.php?p=245238#p245238




Ref

[DocAElstein]

Full macro version for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic.php?p=271960#p271960



Sub Ha2b() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left
Dim LrM As Long: Let LrM = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row ' Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & LrM + 1 & "").Value2 ' The only data needed to ba considered is column A. The "magic code line" will be used to get all our results in one go I need +1 to use an empty line in determining when the last name in the list has something different after it ##
Rem 2 Outer loop Do ing While data is still there in column A
Dim CntIn As Long: Let CntIn = 1 ' This will be for counting as We go down rows in column A
Dim strTRw As Long: Let strTRw = 2 ' We are wanting to determine the start and stop row of a grouped names section. The first one will be at row 2

Do ' ================================================== ======== Main Outel loop for unique name section==
Rem 3 Inner Loop for a section of names ' ---------------------------------------------------------------
Do
'3a) get the row indicies for this section
Let CntIn = CntIn + 1
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) ' this means we are not yet at the end of a section ---
'3b) start doing stuff for each unique name
'3b(i) The workbook with unique name
Workbooks.Add
Dim WbNme As String: Let WbNme = arrA(CntIn, 1) & ".xlsx" ' The current last unique name will be the new Workbook name
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)
'3b(ii) The "vertical" array of row indicies required for "magic code line"
Dim StpRw As Long: Let StpRw = CntIn ' this is the last row for a group of names
Dim RwsT() As Variant ' I need Variant because the Evaluate(" ") methond below returns its field of values in housed in Variant type elements
Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")")
'3b(iii) The "magic code line"
Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation
'3b(iv) Output to first worksheet in workbook and close and save it
'Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' I am missing the Header row so start at top left A2 to leave space for the Header
WsM.Range("A1:C1").Copy ' Header row
Ws.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Workbooks(WbNme).Close Savechanges:=True
'3b(v) Some tidying up before we possibly go to the next unique name
Let strTRw = CntIn + 1 ' I assume the next row is the next name
Loop While CntIn < LrM
' ================================================== ================================================== ===


End Sub
' simplified version
Sub Ha2b_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim LrM As Long: Let LrM = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & LrM + 1 & "").Value2
Dim CntIn As Long: Let CntIn = 1
Dim strTRw As Long: Let strTRw = 2
Do
Do
Let CntIn = CntIn + 1
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1)
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx"
Dim Ws As Worksheet: Set Ws = Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1)
Dim StpRw As Long: Let StpRw = CntIn
Dim RwsT() As Variant
Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")")
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
WsM.Range("A1:C1").Copy
Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True
Let strTRw = CntIn + 1
Loop While CntIn < LrM
End Sub


Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic.php?p=245238#p245238




Ref

[DocAElstein]

Full macro versions for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic.php?p=271960#p271960


Sub DaDoRunRonDeDo2() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr & "").Value2
Rem 2 obtain unique values from column A
' 2a) A single string containing the unique names
Dim Cnt As Long
For Cnt = 2 To Lr Step 1
Dim strUnics As String
If InStr(1, strUnics, arrA(Cnt, 1), vbBinaryCompare) = 0 Then
Let strUnics = strUnics & arrA(Cnt, 1) & " "
Else
' we already had that name in the string
End If
Next Cnt
Let strUnics = Left(strUnics, (Len(strUnics) - 1)) ' Take off last space
' 2b) A 1 dimansional array of the unique names
Dim arrUnics() As String: Let arrUnics() = Split(strUnics, " ", -1, vbBinaryCompare)
Rem 3 Do it for each unique name
Dim WbCnt As Long: Let WbCnt = UBound(arrUnics()) + 1 ' +1 is needed because Split function returns an array starting at indicia 0
For WbCnt = 1 To WbCnt ' Main outer Loop ========================================
' 3a) Get our indicies for the rows wanted of our current name
Dim strRws As String: Let strRws = "1" ' We are building a string of our required row indicia for a unique name. The first row , the header, will always be needed
For Cnt = 2 To Lr Step 1
If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then
Let strRws = strRws & " " & Cnt
Else
' The name is not one of the current name being considered
End If
Next Cnt
'3b) start doing stuff for each unique name
'3b(i) The workbook with unique name
Workbooks.Add
Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 1) & ".xlsx" ' The current last unique name will be the new Workbook name
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)

'3b(ii) The "vertical" array of row indicies required for "magic code line"
Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) ' I can make a 1 Dimesional pseudo "horizontal" array easilly, from which the "horizontal array, RwsT() can be made
Dim RwsT() As String ' I must make this a dynamic array, even though I know the dimensions, because the Dim statement will only take hard coded numbers, wheras the ReDim method below allows us to make the sizing dynamic based on the size of Rws()
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) ' The +1 comes in because the Split function returns a 1D array starting at indicia 0
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
'3b(iii) The "magic code line"
Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation
'3b(iv) Output to first worksheet in workbook and close and save it
Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
Workbooks(WbNme).Close Savechanges:=True
'3b(v) Some tidying up before we possibly go to the next unique name
Let strRws = "1" ' we must reset this, or else we will still have row indicies in it from the last unique name

Next WbCnt ' ================================================== ===================
End Sub

' simplified version
Sub DaDoRunRonDeDo2_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr & "").Value2
Dim Cnt As Long
For Cnt = 2 To Lr Step 1
Dim strUnics As String
If InStr(strUnics, arrA(Cnt, 1)) = 0 Then strUnics = strUnics & arrA(Cnt, 1) & " "
Next Cnt
Dim arrUnics() As String: Let arrUnics() = Split(Trim(strUnics))
Dim WbCnt As Long
For WbCnt = 1 To UBound(arrUnics()) + 1
Dim strRws As String: Let strRws = "1"
For Cnt = 2 To Lr Step 1
If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then strRws = strRws & " " & Cnt
Next Cnt
Workbooks.Add
Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 1) & ".xlsx"
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrUnics(WbCnt - 1) & ".xlsx"
Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare)
Dim RwsT() As String
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1)
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
Let Workbooks(arrUnics(WbCnt - 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
Workbooks(arrUnics(WbCnt - 1) & ".xlsx").Close Savechanges:=True
Let strRws = "1"
Next WbCnt
End Sub





Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic.php?p=245238#p245238

[DocAElstein]

Post for later use
Required to get URL now

[DocAElstein]

In support of this Thread post
https://www.excelforum.com/excel-programming-vba-macros/1327810-delete-rows-based-on-two-criteria-matching-to-entries-on-another-sheet.html#post5397531



Option Explicit and variable declaration
Hello
You can easily find lots of information on the internet that can explain Option Explicit , ( just a few examples given in the Refs below). But my take on it for you:
The simple answer to your specific question is that its not necessary, its just personal choice.
It’s all related to the issue of declaring variables – its difficult to discuss the issue of Option Explicit without discussing the variable declaration issue: In VBA it is not necessary to declare variables. If you use a variable, without an initial declaration, then it will be created “on the fly” as you use them. Mostly they will then be given the Variant type
What a code line at the top of a code module, of Option Explicit , does, is enable the option of being explicit for variable declaration. In other words, it forces you to declare all your variables: If you have this code line at the top of your code module, but then in any coding don’t declare any variable, you will get a warning error, on attempting to run your macro.

Simple Examples
Lets say you make a simple Typo, and write MyMsg , when you meant MyMsig. The following macro won’t error, but it wont give the answer you may have expected.
Sub Testit()
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub
https://i.imgur.com/WwnXByf.jpg
There’s nufin there in that Message Box! – Why? – The message box is using variable MyMsg: The variables MyMsig and MyMsg were created “on the fly”, as you used them, but MyMsg has not been used yet. There is no error, but you did not get to be warned of your likely typo of writing MyMsg instead of MyMsig

The next 2 macros would warn you of undeclared variables with a compile error on attempting to run them
Option Explicit
Sub Testit()
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub
https://i.imgur.com/LlXPOfj.jpg
That last macro did not catch your Typo, but if you corrected that missing declaration for MyMsig, then you would still go on to get the warning of the non declared MyMsg
Option Explicit
Sub Testit()
Dim MyMsig As String
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub
https://i.imgur.com/D9KsQuG.jpg
In fact, in the last macro you would have had the possibility to notice your mistake whilst writing the code line
MsgBox Prompt:=mymsg , provided that you had written it in lower case:
If you had written it just like that, lowercase, mymsg, - having done that, then mymsg would have stayed lowercase when you moved on to writing the next line. On the other hand, If any variable had been declared using any Uppercase characters, then on writing that variable name in lower case characters, and then moving on to the next line, that previous code line would have been changed automatically by the VB Editor to show the correct variable word, including any capital characters.
So an additional point from that experiment is that, if you do choose to declare your variables, then its worth considering using at least one capital in your variable name, but then going on when writing the variable further in the macro to use just lower case always. The VB Editor should automatically correct all your variables, ( and incidentally also correct any commands you type in lower case ) to their correct form including any upper case characters: So, if something remains lower case when you move on to writing the next code line, then you have an immediate indication that something is probably wrong, ( mostly*** ).
( The automatic capitalisation is not directly related to using Option Explicit, but is related to the issue of declaring variables. The use of Option Explicit is mostly of consideration when considering how you choose to handle your variable usage).

So you have a couple of good reason to choose to use Option Explicit and declare your variables carefully.

But you do not have to use Option Explicit
Most people prefer to declare all variables, and to use Option Explicit
There are some people , amongst them respected professionals who go against the trend, don’t use Option Explicit, and consider the use of declaration only where really needed, for example when working when working with class modules. The reasoning is usually given as to avoid redundancy in coding, keeping coding as efficient as possible.

Its personal choice. Do anyfin ya wanna do :)

Molly



Ref:
http://www.eileenslounge.com/viewtopic.php?p=265556#p265556

http://www.eileenslounge.com/viewtopic.php?f=30&t=2281

*** Unfortunately life is not so simple with Microsoft. A bug can cause the automatic capitalization to fail. If you notice this, for example when known commands stay lowercase, then the only known cure seems to be to restart Excel and/ or your computer.

[DocAElstein]

In support of this Thread:
http://www.eileenslounge.com/viewtopic.php?p=271368#p271368





For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"

' HPageBreaks.Add
ThisWorkbook.Worksheets("consultant doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "")

Next Cnt


Sub Solution6() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"

' HPageBreaks.Add
ThisWorkbook.Worksheets("consultant doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "")

Next Cnt

' First half##
' Second stage output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
' HPageBreaks.Add
ThisWorkbook.Worksheets("Specialist Doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "")
Next Cnt

End Sub

[DocAElstein]

In support of this Thread:
http://www.eileenslounge.com/viewtopic.php?p=271368#p271368



Sub Solution7() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("consultant doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"

' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("consultant doctor")
Next Cnt

' First half##
' Second stage output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("Specialist Doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("Specialist Doctor")
Next Cnt

End Sub

[DocAElstein]

In support of this Thread:
http://www.eileenslounge.com/viewtopic.php?p=271368#p271368


'Second half worksheet Consultant doctor
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("consultant doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"

' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("consultant doctor")
Next Cnt





'Second half worksheet Specialist Doctor
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("Specialist Doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("Specialist Doctor")
Next Cnt

[DocAElstein]

In support of this Thread post
http://www.eileenslounge.com/viewtopic.php?p=272989#p272989



Sub Solution8() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
ThisWorkbook.Worksheets("Consultant doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("consultant doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("consultant doctor")

Next Cnt

' First half##
' Second stage output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
ThisWorkbook.Worksheets("Specialist Doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("Specialist Doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("Specialist Doctor")
Next Cnt

End Sub

[DocAElstein]

In support of this Thread post
http://www.eileenslounge.com/viewtopic.php?p=272989#p272989
Part 1 of 3

Sub Solution8b() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7" ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc

[DocAElstein]

In support of this Thread post
http://www.eileenslounge.com/viewtopic.php?p=272989#p272989

part 2 of 3


' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")


Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
' I need my array to be like 137 rather than like 109 strRws() is 0 To 108 ,
' 137 is ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1
' Missing is ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1)
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' At this point we have all the rows with data and the inbetween inserted rows, but we want to extent the output array enough to have the entire range so that I can also paste out the final words and formulas in it
Dim LstEmptyRws As Long: Let LstEmptyRws = ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1)
Let strSuc = strSuc & "" & Evaluate("=REPT("" 1""," & LstEmptyRws & ")") ' ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' Stop
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim RwsT() As Variant, ClmsT() As Variant
Let ClmsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 2 3 4 5 6 .....
Let RwsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 1 1 1 1 1 1 .....
Let RwsT() = Application.Index(strRws(), RwsT(), ClmsT())
Dim arrOut() As Variant ' This is the main output, all in one go. But we can put some values into the array before...
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, RwsT(), Clms())
' ... we can put some values (words) and formulas into the array before we paste it out
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' ... we can put some values into the array before...
Let arrOut(Cnt + 1 - 6, 1) = "The total" ' -6 is because we have top right of A7
Let arrOut(Cnt + 7 - 6, 1) = "Previous total"
Dim Cl As Long ' formulas
For Cl = 4 To 24 ' D To X
Let arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Next Cl
' First signature Second signature third signature Fourth signature Fifth signature
' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Let arrOut(Cnt + 2 - 6, 7) = "Second signature"
Let arrOut(Cnt + 2 - 6, 12) = "Third signature"
Let arrOut(Cnt + 2 - 6, 17) = "Forth signature"
Let arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Next Cnt
' Main paste out of all data and some words and formulas
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
ThisWorkbook.Worksheets("Consultant doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("consultant doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
' .Range("A" & Cnt + 1 & "").Value = "The total"
' .Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("consultant doctor")

Next Cnt
' delete last unwanted Previous Total row
ThisWorkbook.Worksheets("consultant doctor").Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete shift:=xlUp ' http://www.eileenslounge.com/viewtopic.php?p=271328#p271328 ....Go back to my first post, and look at my maths logic. In the macro we have ((Segs * 27) + ((Segs - 1) * 7) + 7) This returns us for consultant doctor 136 and for worksheet Specialist Doctor 102 I think you can see how to get 143 and 109 from those two numbers ( I will give you a clue: The answer is +7 )...."
' End first stage worksheet_________________________________________ __________________________________________________

'

[DocAElstein]

In support of this Thread post
http://www.eileenslounge.com/viewtopic.php?p=272989#p272989

part 3 of 3



'
' First half##
' Second stage output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' At this point we have all the rows with data and the inbetween inserted rows, but we want to extent the output array enough to have the entire range so that I can also paste out the final words and formulas in it
'Dim LstEmptyRws As Long
Let LstEmptyRws = ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1)
Let strSpit = strSpit & "" & Evaluate("=REPT("" 1""," & LstEmptyRws & ")") ' ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim RwsT() As Variant, ClmsT() As Variant
Let ClmsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 2 3 4 5 6 .....
Let RwsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 1 1 1 1 1 1 .....
Let RwsT() = Application.Index(strRws(), RwsT(), ClmsT())

'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, RwsT(), Clms())
' ... we can put some values (words) and formulas into the array before we paste it out
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' ... we can put some values into the array before...
Let arrOut(Cnt + 1 - 6, 1) = "The total" ' -6 is because we have top right of A7
Let arrOut(Cnt + 7 - 6, 1) = "Previous total"
'Dim Cl As Long ' formulas
For Cl = 4 To 24 ' D To X
Let arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Next Cl
' First signature Second signature third signature Fourth signature Fifth signature
' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Let arrOut(Cnt + 2 - 6, 7) = "Second signature"
Let arrOut(Cnt + 2 - 6, 12) = "Third signature"
Let arrOut(Cnt + 2 - 6, 17) = "Forth signature"
Let arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Next Cnt
' Main paste out of all data and some words and formulas
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
ThisWorkbook.Worksheets("Specialist Doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("Specialist Doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
' .Range("A" & Cnt + 1 & "").Value = "The total"
' .Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("Specialist Doctor")
Next Cnt
' delete last unwanted Previous Total row
ThisWorkbook.Worksheets("Specialist Doctor").Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete shift:=xlUp ' http://www.eileenslounge.com/viewtopic.php?p=271328#p271328 ....Go back to my first post, and look at my maths logic. In the macro we have ((Segs * 27) + ((Segs - 1) * 7) + 7) This returns us for consultant doctor 136 and for worksheet Specialist Doctor 102 I think you can see how to get 143 and 109 from those two numbers ( I will give you a clue: The answer is +7 )...."
'
End Sub

[DocAElstein]

In support of this Post
https://eileenslounge.com/viewtopic.php?p=273285#p273285


Sub Solution9ProObfuscation()
Application.ScreenUpdating = False
Dim arrK() As Variant: arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
Dim strSuc As String, strSpit As String
strSuc = "7": strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then
strSuc = strSuc & " " & Cnt
Else
strSpit = strSpit & " " & Cnt
End If
Next Cnt
Dim Clms() As Variant: Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: strRws() = Split(strSuc)
Dim strNms() As Variant: strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
Dim rOuter As Long
For rOuter = 2 To UBound(strNms)
Dim rInner As Long
For rInner = rOuter + 1 To UBound(strNms)
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant
varTemp = strNms(rOuter): strNms(rOuter) = strNms(rInner): strNms(rInner) = varTemp
Dim TempRs As String
TempRs = strRws(rOuter - 1): strRws(rOuter - 1) = strRws(rInner - 1): strRws(rInner - 1) = TempRs
Else
End If
Next rInner
Next rOuter
strSuc = Join(strRws(), " ")
Dim Segs As Long: Segs = Int(((Len(strSuc) - Len(Replace(strSuc, " ", ""))) + 1) / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6)
Next Cnt
strSuc = strSuc & "" & Evaluate("=REPT("" 1""," & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(Split(strSuc)) + 1) & ")"): strRws() = Split(strSuc)
Dim arrOut() As Variant
arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Application.Index(strRws(), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")"), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")")), Clms())
With ThisWorkbook.Worksheets("consultant doctor")
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
arrOut(Cnt + 1 - 6, 1) = "The total": arrOut(Cnt + 7 - 6, 1) = "Previous total"
Dim Cl As Long
For Cl = 4 To 24
arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C": arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Next Cl
arrOut(Cnt + 2 - 6, 2) = "First signature": arrOut(Cnt + 2 - 6, 7) = "Second signature": arrOut(Cnt + 2 - 6, 12) = "Third signature": arrOut(Cnt + 2 - 6, 17) = "Forth signature": arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50: .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
Next Cnt
.Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
With .UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
.Rows("7:7").RowHeight = 50
.Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete
End With
strRws() = Split(strSpit)
strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
For rOuter = 2 To UBound(strNms)
For rInner = rOuter + 1 To UBound(strNms)
If strNms(rOuter) > strNms(rInner) Then
varTemp = strNms(rOuter): strNms(rOuter) = strNms(rInner): strNms(rInner) = varTemp
TempRs = strRws(rOuter - 1): strRws(rOuter - 1) = strRws(rInner - 1): strRws(rInner - 1) = TempRs
Else
End If
Next rInner
Next rOuter
strSpit = Join(strRws(), " ")
Segs = Int(((Len(strSpit) - Len(Replace(strSpit, " ", ""))) + 1) / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6)
Next Cnt
strRws() = Split(strSpit)
strSpit = strSpit & "" & Evaluate("=REPT("" 1""," & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1) & ")")
strRws() = Split(strSpit)
arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Application.Index(strRws(), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")"), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")")), Clms())
With ThisWorkbook.Worksheets("Specialist Doctor")
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
arrOut(Cnt + 1 - 6, 1) = "The total": arrOut(Cnt + 7 - 6, 1) = "Previous total"
For Cl = 4 To 24
arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C": arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Next Cl
arrOut(Cnt + 2 - 6, 2) = "First signature": arrOut(Cnt + 2 - 6, 7) = "Second signature": arrOut(Cnt + 2 - 6, 12) = "Third signature": arrOut(Cnt + 2 - 6, 17) = "Forth signature": arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50: .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
Next Cnt
.Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
With .UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
.Rows("7:7").RowHeight = 50
.Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete
End With
Application.ScreenUpdating = True
End Sub

[DocAElstein]

In support of these Threads
' https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/
' https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html
https://www.excelforum.com/tips-and-tutorials/758402-vba-working-with-areas-within-2d-arrays.html#post5408376





I am not totally sure what the OP is asking.
Is the OP asking
(i) _ to put values into an existing array where that existing array already has values in it
or
(ii)_ changing the array dimension and positioning of elements in an array
or
(iii)_ maybe its lost in the translation and/ or the OP is not sure him/herself.
The initial answer to (i)_ I think we seem clear about:- It will likely in VBA require a code line for each element to be “moved” from one array to the other , so likely looping will be involved for a multi element array.
The Thread title and OPs first question infers to me converting a 1 D array to a 2 D array, without looping.
If the existing array with values already in it is a dynamic array, then overwriting along with re dimensioning means that those (i)_ and (ii)_ are somewhat merged in meaning anyway.
So I am not totally clear what is going on here, but I think it there is a discussion of generally … …”1 D arrays to 2 D arrays”
So lets say we are talking generally about …”1 D arrays to 2 D arrays” and leave it loosely defined for now and go with that…

Frederick has shown in his second code line that a characteristic of the Transpose function is that if a 1 D array is given to the Transpose function then the transposed array becomes a 2 D array , all be it a quasi “1 column array” ***
Transpose does that, as it does the opposite way converting a single column 2D array to a 1D array.
I think most of us are not quite sure why it has been wired to do that. Some other things seem to default to making a “one row” thing be a 1D array rather than a 2D array, even when the thing it may have been given to work on was a 2D array. ( It does not screw things up to badly when playing with spreadsheets since that transposed in its final 1 D form will be “seen” by Excel as if it was a single row 2 Dimensional array when applied to a spreadsheet range. So usually a “row” becomes a row, if you catch my drift).
We can go the other way. ( If we do that with Rick’s example , we will see a small difference, the 1 D array returned will have indices of 1 2 3 4 5 as opposed to the 0 1 2 3 4 , (since the Split function Rick used returns those starting a base 0 ) . I am not sure why Excel chooses to start a t 1 in this case: Possibly it was just made that way because its more often to do with worksheet/spreadsheet stuff, and we think about rows and columns starting at 1, and something like a row of 1 is a bit stupid. )

Index with arrays as co ordinate arguments
This stuff is worth knowing about:
A further function that can be very helpful in doing this sort of manipulation of arrays without looping is the Index Function. It becomes so useful because it will accept arrays in place of the more conventional single value indices in its second ( row ) and third ( column ) arguments. The evaluation is then done in the conventional Excel way, “along the columns of a row” , then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row , ….etc. Usually VBA will do its best to give out the results in an array dimensioned appropriate for the array dimensions supplied in those second and third arguments, following the conventional “along the columns of a row” , then down to repeat at the next row: along the columns of that row, ………

As example we can do that Transpose code line in this pseudo way

' Index(OneDimensionalArray(), 1 , 1
' 1 2
' 1 3
' 1 4
' 1 5 )
We are doing 5 calculations there, talking each time the first row and consecutive columns, the result coming out in a form that the Excel calculations are done - .. “along the columns of a row” , then down to repeat at the next row… but we only have one column in this case, so that is actually just going down the rows, 5 times. Hence our output is the 90degree transpose of OneDimensionalArray()

That was just one example, but the important point is that you can supply different arrays in the Index second ( “row” ) and third ( “column” ) arguments. So you can pretty well take any1 or 2 D array in the Index first argument, and in one code line, without looping , put all or some of the values from that array in some other order in any other 1 or 2 D array. That could be what the OP was asking for ….
Dim Array1(2, 2) As Integer
Dim Array2(2) As Integer
…………… way to copy the values from Array2 into Array1?
The restriction is that we can’t make use of this to put values into Array1( ) if it already existed. You would have to be in like having
Dim Array1() As Variant
Dim Array2(2) As Integer
-……..
Array1()= Index ( Array2(2) , { _.... } , { _... } )
( Variant is needed in the first declaration as the index chucks its output values housed in Variant types. AFAIK the first argument can be any sort of 1 D or 2 D array, ( or it can be any range object ) )

Another not looping option to assist in a conversion could be to remove rows or columns of a 2 D array with a single code line. Best look at some posts of Rick ( Frederick Rothstein (https://excelfox.com/forum/forumdisplay.php/22-Rick-Rothstein-s-Corner) ‘s ) , stuff for that ( https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array )


One last curiosity , a weird thing I only recently came across. An array of arrays, sometimes refereed as a “jagged array”, is peculiarly treated in some cases by Index as a 2 D array. This gives us some interesting further one liner code line possibilities.
Example, If I had a 1 D array of 1 D arrays, something of this sort of form
{ { “Head1” , 2, 3 } , {“Head3”, 4, 5 } , {“Haed2”, 7, 9} }
then I can convert that, for example, to re ordered in data columns like this

' Head1 , Haed2 , Head3
' 2 , 7 , 4
' 3 , 9 , 5
I can do that using like a Index one code liner pseudo

' Index( Head1 , 2, 3 1 , 3 , 2 1 , 1 , 1
' Head3 , 4, 5 1 , 3 , 2 2 , 2 , 2
' Haed2 , 7, 9 1 , 3 , 2 3 , 3 , 3 )



I put some more details of all I have been saying , in a macro in the uploaded file. Probably its best to step through the macro in Debug mode ( do that by hitting Key F8 after clicking anywhere in the macro )




....to be honest with you I've never seen your type of question asked in 20 years of writing code my lifetime. ....
Hello Adam.
I expect you are referring specifically to the idea of putting existing values from an array into another existing array, although I am not fully clear if the OP wanted that: Possibly the language barrier prevented the OP getting anything out of the links you gave him…. The best thing probably, as Rory asked for, was an example from the OP of what he wanted to do…
Anyway, you probably know all the following, but I thought I’d add it to the Thread, while I am in the mood…
Generally questions along the lines of “1 D array to 2 D array” or visa versa are quite common in Excel VBA. I expect this is because
_ a) a lot of things done “internally” in coding involve 1 D arrays,
but/ and
_ b) a range from a spreadsheet will often likely end up in an array of 2 Dimensions, I think Excel does this so that we can make the distinction what is a row and what is a column.***
So things might not always work as we wanted, for example a problem might occur when a 1 D array appears when a 2 D array was expected/ wanted, and visa versa. To solve the problem a conversion from a 1D to 2D or visa versa might get us out of trouble.
Example: we got a Join function that is something like the reverse of the Split function mentioned in this Thread (https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5402848). Basically you can use it to join the contents of an array into a string. The bummer is that it only accepts a 1 D array. So if I give it a column or row of data to join it will error. You’ll need to change the 2D array got from a spreadsheet single row or a spreadsheet single column to a 1D array for join to work on it. ( One way you can do that is with some of the one liner codings I been talking about – I added a example for you in the uploaded macro ### )

***I suppose a 2 D array does not really have “rows” and “columns”, it simply has 2 dimensions. But Excel conventionally puts a spreadsheet row into the fist dimension, and a spreadsheet column into the second dimension. So after using Excel VBA arrays a lot you often get to think of a 2 D array in terms of like arr(row, column) or in terms of orientation like arr(horizontal, vertical). Its just a convenient frame of reference perception.
A 1 D array has no orientation. I can’t really perceive that unless I have drunk a lot of Jack Daniels, as the world starts spinning around, then it becomes very clear, relatively speaking. I suppose Excel can’t get drunk, and as mentioned, a 1 D array seems to be often regarded as like a 2 D array of first dimension size of 1, or pseudo 1 “row” 2 D array.

Molly







Adam, I have definitely had random occurrences of an error like you mentioned, all be it very rarely. When it has happened , I was pretty damm sure it shouldn’t have happened.
I think we all agree that Activateing and Selecting when dealing with worksheet ranges via VBA is rarely needed and is usually a bad idea as the interaction with a spreadsheet slams the brakes on.

I will usually optimise a macro first, with no Activateing and Selecting , ignoring the odd error of that sort you mentioned.
After that I will often see if I don’t compromise the performance much if I add an occasional code line pair of something like
Worksheet("x").Activate: Worksheet("x").Range("A1").Select
Or, if dealing with multiple open workbooks,
Workbooks("x“).Activate: Worksheet("x").Activate: Worksheet("x").Range("A1").Select
at some strategic points.

A typical point would be just before I start doing things to ranges in Worksheet("x") via VBA. I know those two ( three ) code lines should be unnecessary. But it’s been my experience that they help stop that occasional error.
I have no idea what causes the occasional error when all suggest it should not error. I think possibly Excel has some memories of what was last active. Possibly that can become corrupted, and doing a quick Worksheet("x").Activate: Worksheet("x").Range("A1").Select refreshes it.

One thing that has already been touched on here in the Thread a couple of times, which has caught me out a few times: Selecting a range does not activate the worksheet of the range you select.
If the worksheet is not active and you try to select that range then you will get that error.
But selecting a worksheet does activate that worksheet. (Activateing and Selecting a worksheet do something similar, - I think the main difference being that you can select things, but only activate a thing. I have not explored that much yet… )


…but based on the millions of tests that I ran, it became evident that this line of code automatically made the book active:


wbDrawings.SaveAs (ThisWorkbook.Path & Application.PathSeparator & "temp.csv")
.....I would hazard a guess that that might be version dependent and possibly unreliable, as Rory suggested. That dose not consistently activate the workbook being saved, for me.

Molly

[DocAElstein]

Some additional notes and extended explanations in support of answer to this Thread
https://eileenslounge.com/viewtopic.php?f=30&t=35303&sid=0c127b1ad1adf77124fc302dc186f01b

The OP has this
_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFG
1Header1Header2Header3Header4Header5Header6Header7

2101H2_1H3_1H4_1H5_1H6_1H7_1

3102H2_2H3_2H4_2H5_2H6_2H7_2

4103H2_3H3_3H4_3H5_3H6_3H7_3

5102H2_4H3_4H4_4H5_4H6_4H7_4

6101H2_5H3_5H4_5H5_5H6_5H7_5

7103H2_6H3_6H4_6H5_6H6_6H7_6

8105H2_7H3_7H4_7H5_7H6_7H7_7

9104H2_8H3_8H4_8H5_8H6_8H7_8
Worksheet: Source

This what the OP wants
_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )
Row\ColCDEF
2MyTargetHeader3Header4Header7

3101H3_1H4_1H7_1

4101H3_5H4_5H7_5

5101

6102H3_2H4_2H7_2

7103H3_3H4_3H7_3

8103H3_6H4_6H7_6

9104H3_8H4_8H7_8

10108

11105H3_7H4_7H7_7
Worksheet: Target

Here again what the OP wants, with explanations:

Expected Result

MyTargetHeader3Header4Header7

101H3_1H4_1H7_1first instance

101H3_5H4_5H7_5second instance

101third instance (there is no third instance so left empty)

102H3_2H4_2H7_2

103H3_3H4_3H7_3

103H3_6H4_6H7_6

104H3_8H4_8H7_8

108left empty as there is no 108 in Source

105H3_7H4_7H7_7

You can see that it comes from the source worksheet:

Header1Header2Header3Header4Header5Header6Header7

101H2_1H3_1H4_1H5_1H6_1H7_1

102H2_2H3_2H4_2H5_2H6_2H7_2

103H2_3H3_3H4_3H5_3H6_3H7_3

102H2_4H3_4H4_4H5_4H6_4H7_4

101H2_5H3_5H4_5H5_5H6_5H7_5

103H2_6H3_6H4_6H5_6H6_6H7_6

105H2_7H3_7H4_7H5_7H6_7H7_7

104H2_8H3_8H4_8H5_8H6_8H7_8




Rem 1
The main start point on my logic is obtaining ( in a dynamic way ) a range ( in an array , arrSrch() , ) that looks like this

Header1Header3Header4Header7

101H3_1H4_1H7_1

102H3_2H4_2H7_2

103H3_3H4_3H7_3

102H3_4H4_4H7_4

101H3_5H4_5H7_5

103H3_6H4_6H7_6

105H3_7H4_7H7_7

104H3_8H4_8H7_8


Note: The array arrSrch() has an extra empty row
https://imgur.com/fKjli8W https://i.imgur.com/fKjli8W.jpg


What we do with that is the subject of Rem 2 , and is explained in the next post (https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14906&viewfull=1#post14906)

[DocAElstein]

Continued from last post (https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14905&viewfull=1#post14905)

Rem 2
We build up a Main 1D array whose elements are themselves 1 D arrays of the required output rows.
This is done by looping down the target range rows , arTgt() = WsT.Range("C2:C" & LrT & "").Value
At each loop we look for a match of the target range row value in the first column of arrSrch()
We then do the array Split type technique ( https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index ) to get a 1 D array of the required row. That row is added to the Main 1 D array
We then remove that row from arrSrch() ( using a function from Rick Rothstein https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array ).
Then we move on to the next target range row down

Rem 3
Our output array is a 1D array of 1D arrays , but we noticed that we can treat that in Index as a 2D array https://eileenslounge.com/viewtopic.php?p=266691#p266691
For demo purposes, the macro in the next post (https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14907&viewfull=1#post14907) pastes out the result in a spare worksheet range:

' Example paste out CHANGE Top left cell H35 to suit
Let WsT.Range("H35").Resize(UBound(arrOut(), 1) - 1, UBound(arrOut(), 2)).Value = arrOut() ' ** -1 is a bodge to knock off the extra row
End Sub

_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )
Row\ColHIJ
35H3_1H4_1H7_1

36H3_5H4_5H7_5

37

38H3_2H4_2H7_2

39H3_3H4_3H7_3

40H3_6H4_6H7_6

41H3_8H4_8H7_8

42

43H3_7H4_7H7_7
Worksheet: Target

Macro, Sub BrdShlss() , and a couple of required Functions are here:
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14907&viewfull=1#post14907

[DocAElstein]

Macro for these posts
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14905&viewfull=1#post14905
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14906&viewfull=1#post14906
http://www.eileenslounge.com/viewtopic.php?f=30&t=35303




Option Explicit
Sub BrdShlss() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35303 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14907&viewfull=1#post14907
Rem 1 worksheets data info
Dim WsS As Worksheet, WsT As Worksheet
Set WsS = ThisWorkbook.Worksheets("Source"): Set WsT = ThisWorkbook.Worksheets("Target")
Dim LrS As Long, LrT As Long, LcS As Long, LcT As Long
Let LrS = WsS.Range("A" & WsS.Rows.Count & "").End(xlUp).Row
Let LrT = WsT.Range("C" & WsT.Rows.Count & "").End(xlUp).Row
Let LcS = WsS.Cells(1, WsS.Columns.Count).End(xlToLeft).Column
Let LcT = WsT.Cells(2, WsT.Columns.Count).End(xlToLeft).Column
Dim arSrc() As Variant ', arSrcA() As Variant
Let arSrc() = WsS.Range("A1:" & CLtr(LcS) & LrS + 1 & "").Value ' + 1 is to give us an extra empty row
' Let arSrcA() = WsS.Range("A1:A" & LrS & "").Value
Dim arTgt() As Variant: Let arTgt() = WsT.Range("C2:C" & LrT & "").Value
'1b) determine what columns are needed for our search range, since typically not all are needed
Dim strClms As String: Let strClms = "1"
Dim SrchHd() As Variant: Let SrchHd() = WsT.Range("D2:" & CLtr(LcT) & "2").Value
Dim SrcHd() As Variant: Let SrcHd() = WsS.Range("A1:" & CLtr(LcS) & "1").Value
Dim Cnt As Long
For Cnt = 1 To UBound(SrchHd(), 2)
Dim MtchRes As Long ' Note I assume there is always a match in Headers between sheet ranges, so that I always have a number and not an error string
Let MtchRes = Application.Match(SrchHd(1, Cnt), SrcHd(), 0)
Let strClms = strClms & " " & MtchRes ' add a required column indicie

Next Cnt
' Let strClms = Left(strClms, (Len(strClms) - 1)) ' remove last unwanted space For the given example this gives us "3 4 7"
Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & LrS + 1 & ")") ' + 1 is to give us an extra empty row
Dim arrSrch() As Variant ' This will be the reduced size range we need to search in - it has just the headers required
Let arrSrch() = Application.Index(arSrc(), RwsT(), Split(strClms, " ", -1, vbBinaryCompare)) ' In our example Split(strClms, " ", -1, vbBinaryCompare)) is {1, 3, 4, 7)
' Let Range("H24").Resize(UBound(arrSrch(), 1), UBound(arrSrch(), 2)).Value = arrSrch()
'1c) Get initial row string indicies for current source range
'Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & UBound(arSrc(), 1) & ")") ' Typical "vertical" array of row indices needed in Index(Arr, Rws(), Clms()) type code line
'Dim Rws() As Variant: Let Rws() = Application.Index(RwsT(), Evaluate("=Column(A:" & CLtr(UBound(RwsT, 1)) & ")"), Evaluate("=Column(A:" & CLtr(UBound(RwsT(), 1)) & ")/Column(A:" & CLtr(UBound(RwsT(), 1)) & ")")) ' Transpose the "vertical array to get a 1 Dimenrional "horizontal" array
'Dim strRws As String: Let strRws = " " & Join(Rws(), " ") & " " ' This is a string of our row indicies, and later we will remove some indicies as we go along then work the steps above backwards to get a modified RwsT() to use in Index(Arr, Rws(), Clms()) type code line for a new reduced content search array
Rem 2 Building output array
Dim arrOut() As Variant ' A 1 D array for the 1 D arrays at each match
' 2b) main loop for all rows of MyTarget
For Cnt = 2 To UBound(arTgt(), 1) Step 1
ReDim Preserve arrOut(1 To Cnt - 1)
Dim arSrcA() As Variant: Let arSrcA() = Application.Index(arrSrch(), 0, 1) ' the first column of our current arrSrch() ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
Dim VarMtchres As Variant
Let VarMtchres = Application.Match(arTgt(Cnt, 1), arSrcA(), 0)
If IsError(VarMtchres) Then ' we need to add an empty row which we have as the last row of arrSrch()
Let arrOut(Cnt - 1) = Application.Index(arrSrch(), UBound(arrSrch(), 1), 0) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
Else
Let arrOut(Cnt - 1) = Application.Index(arrSrch(), VarMtchres, 0) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
'2b(ii) we must remove the row from the arrSrch()
Let arrSrch() = DeleteArrayRow(arrSrch(), (VarMtchres))
End If
Next Cnt
Rem 3 ' Our output array is a 1D array of 1D arrays , but we noticed that we can treat that in Index as a 2D array https://eileenslounge.com/viewtopic.php?p=266691#p266691
Let arrOut() = Application.Index(arrOut(), RwsT(), Evaluate("=Column(B:" & CLtr(UBound(arrSrch(), 2)) & ")")) ' ** this is actually 1 row too big
' Example paste out CHANGE Top left cell H35 to suit
Let WsT.Range("H35").Resize(UBound(arrOut(), 1) - 1, UBound(arrOut(), 2)).Value = arrOut() ' ** -1 is a bodge to knock off the extra row
End Sub

' https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array
Function DeleteArrayRow(Arr As Variant, RowToDelete As Long) As Variant
Dim Rws As Long, Cols As String
Rws = UBound(Arr) - LBound(Arr)
Cols = "A:" & Split(Columns(UBound(Arr, 2) - LBound(Arr, 2) + 1).Address(, 0), ":")(0)
DeleteArrayRow = Application.Index(Arr, Application.Transpose(Split(Join(Application.Trans pose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(Arr) & ")"))))), Evaluate("COLUMN(" & Cols & ")"))
End Function

' https://excelfox.com/forum/showthread.php/1902-Function-Code-for-getting-Column-Letter-from-Column-Number
Public Function CLtr(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 CLtr = Chr(65 + (((lclm - 1) Mod 26))) & CLtr: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

[DocAElstein]

Some notes in support of these Threads
https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing
https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA


Google Browser Page HTML Source
Typically,
_ the first main section in internet page manipulation codings which try to get things from internet sites, is a code section which gets you a single, very long, text string of something similar to what your browser actually uses to present all you see.
( Google Browser also allows you to see in the browser all that text if you right click and select something like Show Page Source ( or use short cut key combination of Strg+u )
ShowPageSource.JPG PageSource.JPG :
https://imgur.com/UnAs5Le , https://imgur.com/bubFTet
https://i.imgur.com/UnAs5Le.jpg , https://i.imgur.com/bubFTet.jpg )


I am not 100% familiar with all the syntaxes and workings of this first code section, but usually they are similar in such codings, and usually I can get that code section to get the HTML page Source text string, ( and we can add a few extra code lines if we want to put all that text string into a text file , so that we can look at it , and use the simple search facility within a text editor, such as Notepad , to find things in that very long text string )
This first code section will get me that text string for a Google Search of ExcelFox , and it will put it in a text file with the name
GoogleSrchExcelFox.txt

Sub GoogleSearchURL() ' https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA
On Error GoTo Bed
'_1 First section get the long text string of the HTML coding of the internet Page
'_1(i) get the long single text string
With CreateObject("msxml2.xmlhttp")
.Open "GET", "https://www.google.com/search?q=ExcelFox", False ' 'just preparing the request type, how and what type... "The True/False argument of the HTTP Request is the Asynchronous mode flag. If set False then control is immediately returns to VBA after Send is executed. If set True then control is returned to VBA after the server has sent back a response.
'No extra info here for type GET
.setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo"
'.setRequestHeader bstrheader:="If-Modified-Since", bstrvalue:="Sat, 1 Jan 2000 00:00:00 GMT" ' https://www.autohotkey.com/boards/viewtopic.php?t=9554 --- It will caching the contents of the URL page. Which means if you request the same URL more than once, you always get the same responseText even the website changes text every time. This line is a workaround : Set cache related headers.
.send ' varBody:= ' No extra info for type GET. .send actually makes the request
While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option
Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc. The responseText property returns the information requested by the Open method as a text string
End With
'_1(ii) Optional secion to put the text string into a text file , for ease of code developments
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName2 As String
Let PathAndFileName2 = ThisWorkbook.Path & "\" & "GoogleSrchExcelFox" & ".txt" ' CHANGE TO SUIT
Open PathAndFileName2 For Output As #FileNum2 ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum2, PageSrc '
Close #FileNum2


_ The second part of such internet page manipulation coding involve often putting that text into an Object that allows a Object oriented programming type analysis of the web page. That is rather advanced and I personally am not too experienced with that.

What I am proposing is a much simplified approach I used myself successfully a few times. It is so simple, that I guess it may not be reliable permanently, for example, when a small change is made to the source page coding by Google. On the other hand , often major changes make the more advanced coding no longer work.
My solution is probably best only to use if you can understand enough to modify it yourself later when it no longer works. That is why I will explain it in detail here.

Examine the string to find the info you want
My solution does very simple basic string manipulation to pick out what I want.
As example, I do google search for ExcelFox manually and programmatically…_
_ Manually:
https://imgur.com/M16cko3 : https://i.imgur.com/M16cko3.jpg
_ Programmatically :
I run the macro snippet above, and look at the text file produced in a text editor. Then I use the search option to look for ExcelFox
NotepadSearch.JPG , Notepad Search.JPG
https://imgur.com/L9dcXBf , https://imgur.com/K4kl3qk
https://i.imgur.com/L9dcXBf.jpg , https://i.imgur.com/K4kl3qk.jpg
If I compare the results of manually and programmatically, then I can pick out a pattern. ( Note: you must look at all the occurrences of ExcelFox – Some will be as part of a text that you don’t want, but you will see a match between the things shown manually, and the text got programmatically.
Example
My manual search got me this: ExcelFoxManaulGooglesearch.JPG : https://imgur.com/M16cko3
https://i.imgur.com/M16cko3.jpg
Consider the first three main URLs given by the search :
http://www.excelfox.com/forum/forum.php
https://excelfox.com/forum/forumdisplay.php/2-Excel-Help
http://www.hifi-forum.de/bild/excel-fox-700e_737672.html
If I search in the text file, I can pick out those inside a similar text section…

' q=ExcelFox&amp;source=lnms&amp;tbm=nws&amp;sa=X&amp;ved=0ahUKEwjO9 PiFs6jsAhXJzoUKHUj-DwcQ_AUIBygD">NEWS</a></td></tr></tbody></table></div></div><div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=http://www.excelfox.com/forum/forum.php&amp;sa=U&amp;ved=2ahUKEwjO9PiFs6jsAhXJzoUKHUj-DwcQFjAAegQIBxAB&amp;usg=AOvVaw3c8Z4i7W8Ooq7f9a8C3CKw"><span class="CVA68e qXLe6d">Excel,
' <span class="qXLe6d FrIlee"> <span class="fYyStc">Have a question in Excel, Access, Powerpoint, Word or Outlook? Ask http://www.?excelfox.com/forum/forum.php.</span> </span> </div> </div></td></tr></table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://excelfox.com/forum/forumdisplay.php/2-Excel-Help&amp;sa=U&amp;ved=2ahUKEwjO9PiFs6jsAhXJzoUKHUj-
' Weitere Ergebnisse von excelfox.com</a> </span> </div> </div></td></tr></table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=http://www.hifi-forum.de/bild/excel-fox-700e_737672.html&amp;sa=U&amp;ved=2ahUKEwjO9PiFs6jsAhXJzoU KHUj-DwcQFjACegQIABAB&amp;usg=AOvVaw1WljIWpaSLwuTcgdbTcLeU"><span class="CV

I now repeat the above experiment for a Google search on Chandoo
Manual search results:
ChandooManaulGooglesearch.JPG : https://imgur.com/eQSDHsz
https://i.imgur.com/eQSDHsz.jpg
Considering again just the first 3 results , we have
https://chandoo.org/
https://www.youtube.com/channel/UC8uU_wruBMHeeRma49dtZKA
https://de.wikipedia.org/wiki/Chandu
Programmatic ( looking through the produced text file to find something similar to the first 3 URLs from the manual search)
( This would be the macro to get the text file from that search : https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14992&viewfull=1#post14992 )

' /table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://chandoo.org/&amp;sa=U&amp;ved=2ahUKEwiFs9-r4KrsAhWNC-wKHSLMBb0QFjACegQICBAB&
' <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://www.youtube.com/channel/UC8uU_wruBMHeeRma49dtZKA&amp;sa=U&amp;ved=2ahUKEwiFs9-r4KrsA
' /td></tr></table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://de.wikipedia.org/wiki/Chandu&amp;sa=U&amp;ved=2ahUKEwiFs9-r4KrsAhWNC-wKHSLMBb0QFjAEegQIARAB&amp;usg=AOvVaw323MmSfVaurlycQW8 E02XJ"><span class="CVA68e qXLe6d">Chandu – Wikipedia</span> <span class="qXLe6d dX

Solution based on simple string analysis
It appears as if we can easily pick out our required URLs from the text if we look for some of the text appearing just before all the URLs.
We could try for example, class="fuLhoc ZWRArf" href="/url?q=
We know then that the text after is out wanted URL
We can also see that we have consistently the same string after URL, so we know we can look for that in order to know the end of the URL text
The implementation of this is fairly simple VBA string manipulation.

[DocAElstein]

Some notes in support of these Threads
https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing
https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA




Sub GoogleSearchURL() ' https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA
On Error GoTo Bed
'_1 First section get the long text string of the HTML coding of the internet Page
'_1(i) get the long single text string
With CreateObject("msxml2.xmlhttp")
.Open "GET", "https://www.google.com/search?q=Chandoo", False ' 'just preparing the request type, how and what type... "The True/False argument of the HTTP Request is the Asynchronous mode flag. If set False then control is immediately returns to VBA after Send is executed. If set True then control is returned to VBA after the server has sent back a response.
'No extra info here for type GET
.setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo"
'.setRequestHeader bstrheader:="If-Modified-Since", bstrvalue:="Sat, 1 Jan 2000 00:00:00 GMT" ' https://www.autohotkey.com/boards/viewtopic.php?t=9554 --- It will caching the contents of the URL page. Which means if you request the same URL more than once, you always get the same responseText even the website changes text every time. This line is a workaround : Set cache related headers.
.send ' varBody:= ' No extra info for type GET. .send actually makes the request
While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option
Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc. The responseText property returns the information requested by the Open method as a text string
End With
'_1(ii) Optional secion to put the text string into a text file , for ease of code developments
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName2 As String
Let PathAndFileName2 = ThisWorkbook.Path & "\" & "Chandoo" & ".txt" ' CHANGE TO SUIT
Open PathAndFileName2 For Output As #FileNum2 ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum2, PageSrc '
Close #FileNum2
End Sub

[DocAElstein]

In support of this Thread
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria
and answer
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15046&viewfull=1#post15046

This is what the transpose of SM_T_D1() looks like ( SM_T_D1() is actually pseudo horizontal rather than vertical , as it is a 1D array )
_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

Sales Man Territory Dimension

John New York Tissue

Alfred Washington Soda

John New York Soda

Alfred New York Tissue

Leo Washington Soda

Leo New York Tissue

Maxwell Washington Towel



Here is the equivalent transpose of array, SM_T_D2()
_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

Sales Man Territory Dimension

John New York Tissue

John New York Soda

John New York Paper

John New York Towel

John Washington Tissue

John Washington Soda

John Washington Paper

John Washington Towel

Alfred New York Tissue

Alfred New York Soda

Alfred New York Paper

Alfred New York Towel

Alfred Washington Tissue

Alfred Washington Soda

Alfred Washington Paper

Alfred Washington Towel

Leo New York Tissue

Leo New York Soda

Leo New York Paper

Leo New York Towel

Leo Washington Tissue

Leo Washington Soda

Leo Washington Paper

Leo Washington Towel

Maxwell New York Tissue

Maxwell New York Soda

Maxwell New York Paper

Maxwell New York Towel

Maxwell Washington Tissue

Maxwell Washington Soda

Maxwell Washington Paper

Maxwell Washington Towel

[DocAElstein]

In support of this answer
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15046&viewfull=1#post15046


Before:
___ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
1Sales ManTerritoryDimension Sales Amt Cost

2JohnNew YorkTissue
1,000.00
200.00

3AlfredWashingtonSoda
2,100.00
700.00

4JohnNew YorkSoda
2,050.00
1,500.00

5AlfredNew YorkTissue
2,000.00
500.00

6LeoWashingtonSoda
200.00
100.00

7LeoNew YorkTissue
3,500.00
1,500.00

8MaxwellWashingtonTowel
1,000.00
800.00
Worksheet: Export1


_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
1Sales ManTerritoryDimensionSales AmtCost

2JohnNew YorkTissue

3JohnNew YorkSoda

4JohnNew YorkPaper

5JohnNew YorkTowel

6JohnWashingtonTissue

7JohnWashingtonSoda

8JohnWashingtonPaper

9JohnWashingtonTowel

10AlfredNew YorkTissue

11AlfredNew YorkSoda

12AlfredNew YorkPaper

13AlfredNew YorkTowel

14AlfredWashingtonTissue

15AlfredWashingtonSoda

16AlfredWashingtonPaper

17AlfredWashingtonTowel

18LeoNew YorkTissue

19LeoNew YorkSoda

20LeoNew YorkPaper

21LeoNew YorkTowel

22LeoWashingtonTissue

23LeoWashingtonSoda

24LeoWashingtonPaper

25LeoWashingtonTowel

26MaxwellNew YorkTissue

27MaxwellNew YorkSoda

28MaxwellNew YorkPaper

29MaxwellNew YorkTowel

30MaxwellWashingtonTissue

31MaxwellWashingtonSoda

32MaxwellWashingtonPaper

33MaxwellWashingtonTowel
Worksheet: ResultVBA

[DocAElstein]

In support of this Thread
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria
and answer
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15046&viewfull=1#post15046


After running Sub Arrays1()

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
1Sales ManTerritoryDimensionSales AmtCost

2JohnNew YorkTissue1000200

3JohnNew YorkSoda20501500

4JohnNew YorkPaper

5JohnNew YorkTowel

6JohnWashingtonTissue

7JohnWashingtonSoda

8JohnWashingtonPaper

9JohnWashingtonTowel

10AlfredNew YorkTissue2000500

11AlfredNew YorkSoda

12AlfredNew YorkPaper

13AlfredNew YorkTowel

14AlfredWashingtonTissue

15AlfredWashingtonSoda2100700

16AlfredWashingtonPaper

17AlfredWashingtonTowel

18LeoNew YorkTissue35001500

19LeoNew YorkSoda

20LeoNew YorkPaper

21LeoNew YorkTowel

22LeoWashingtonTissue

23LeoWashingtonSoda200100

24LeoWashingtonPaper

25LeoWashingtonTowel

26MaxwellNew YorkTissue

27MaxwellNew YorkSoda

28MaxwellNew YorkPaper

29MaxwellNew YorkTowel

30MaxwellWashingtonTissue

31MaxwellWashingtonSoda

32MaxwellWashingtonPaper

33MaxwellWashingtonTowel1000800
Worksheet: ResultVBA

[DocAElstein]

Some extra clarifying info for this thread
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria
and specifically this post
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15048#post15048


For this range with Helper column


_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEF
1Sales ManTerritoryDimensionHelper Column Sales Amt Cost

2JohnNew YorkTissueJohn|New York|Tissue 1,000.00 200.00

3AlfredWashingtonSodaAlfred|Washington|Soda 2,100.00 700.00

4JohnNew YorkSodaJohn|New York|Soda 2,050.00 1,500.00

5AlfredNew YorkTissueAlfred|New York|Tissue 2,000.00 500.00

6LeoWashingtonSodaLeo|Washington|Soda 200.00 100.00

7LeoNew YorkTissueLeo|New York|Tissue 3,500.00 1,500.00

8MaxwellWashingtonTowelMaxwell|Washington|Towel 1,000.00 800.00
Worksheet: Export

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\Col
D

1
Helper Column


2
=A2&"|"&B2&"|"&C2


3
=A3&"|"&B3&"|"&C3


4
=A4&"|"&B4&"|"&C4


5
=A5&"|"&B5&"|"&C5


6
=A6&"|"&B6&"|"&C6


7
=A7&"|"&B7&"|"&C7


8
=A8&"|"&B8&"|"&C8
Worksheet: Export



Formula VLookUp

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IF(ISERROR(VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,2,FALSE)),"",VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,2,FALSE))
=IF(ISERROR(VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,3,FALSE)),"",VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,3,FALSE))
Worksheet: ResultVLookUp


Formula Index

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IF(ISERROR(INDEX(Export!$E$2:$E$8,MATCH(1,(Result Index!A2=Export!$A$2:$A$8)*(ResultIndex!B2=Export! $B$2:$B$8)*(ResultIndex!C2=Export!$C$2:$C$8),0),1) ),"",INDEX(Export!$E$2:$E$8,MATCH(1,(ResultIndex!A2=Ex port!$A$2:$A$8)*(ResultIndex!B2=Export!$B$2:$B$8)* (ResultIndex!C2=Export!$C$2:$C$8),0),1))
=IF(ISERROR(INDEX(Export!$F$2:$F$8,MATCH(1,(Result Index!A2=Export!$A$2:$A$8)*(ResultIndex!B2=Export! $B$2:$B$8)*(ResultIndex!C2=Export!$C$2:$C$8),0),1) ),"",INDEX(Export!$F$2:$F$8,MATCH(1,(ResultIndex!A2=Ex port!$A$2:$A$8)*(ResultIndex!B2=Export!$B$2:$B$8)* (ResultIndex!C2=Export!$C$2:$C$8),0),1))
Worksheet: ResultIndex

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IFERROR(INDEX(Export!$E$2:$E$8,MATCH(1,(ResultInd ex2!A2=Export!$A$2:$A$8)*(ResultIndex2!B2=Export!$ B$2:$B$8)*(ResultIndex2!C2=Export!$C$2:$C$8),0),1) ,"")
=IFERROR(INDEX(Export!$F$2:$F$8,MATCH(1,(ResultInd ex2!A2=Export!$A$2:$A$8)*(ResultIndex2!B2=Export!$ B$2:$B$8)*(ResultIndex2!C2=Export!$C$2:$C$8),0),1) ,"")
Worksheet: ResultIndex2

[DocAElstein]

Some extra clarifying info for this thread
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria
and specifically this post
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15048#post15048


For this range

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
1Sales ManTerritoryDimension Sales Amt Cost

2JohnNew YorkTissue 1,000.00 200.00

3AlfredWashingtonSoda 2,100.00 700.00

4JohnNew YorkSoda 2,050.00 1,500.00

5AlfredNew YorkTissue 2,000.00 500.00

6LeoWashingtonSoda 200.00 100.00

7LeoNew YorkTissue 3,500.00 1,500.00

8MaxwellWashingtonTowel 1,000.00 800.00
Worksheet: Export1


Index Formulas

From P45cal

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IF(ISERROR(INDEX(Export1!D$1:D$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0))),"",INDEX(Export1!D$1:D$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)))
=IF(ISERROR(INDEX(Export1!E$1:E$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0))),"",INDEX(Export1!E$1:E$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)))
Worksheet: P45cal

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IFERROR(INDEX(Export1!D$1:D$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)),"")
=IFERROR(INDEX(Export1!E$1:E$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)),"")
Worksheet: P45cal1



From Alan ( DocAElstein )

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IF(ISERROR(INDEX(Export1!$D$2:$D$8,MATCH(1,(ResIn dex!A2=Export1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$ 2:$B$8)*(ResIndex!C2=Export1!$C$2:$C$8),0),1)),"",INDEX(Export1!$D$2:$D$8,MATCH(1,(ResIndex!A2=Expo rt1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$2:$B$8)*(Re sIndex!C2=Export1!$C$2:$C$8),0),1))
=IF(ISERROR(INDEX(Export1!$E$2:$E$8,MATCH(1,(ResIn dex!A2=Export1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$ 2:$B$8)*(ResIndex!C2=Export1!$C$2:$C$8),0),1)),"",INDEX(Export1!$E$2:$E$8,MATCH(1,(ResIndex!A2=Expo rt1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$2:$B$8)*(Re sIndex!C2=Export1!$C$2:$C$8),0),1))
Worksheet: ResIndex

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IFERROR(INDEX(Export1!$D$2:$D$8,MATCH(1,(ResIndex 2!A2=Export1!$A$2:$A$8)*(ResIndex2!B2=Export1!$B$2 :$B$8)*(ResIndex2!C2=Export1!$C$2:$C$8),0),1),"")
=IFERROR(INDEX(Export1!$E$2:$E$8,MATCH(1,(ResIndex 2!A2=Export1!$A$2:$A$8)*(ResIndex2!B2=Export1!$B$2 :$B$8)*(ResIndex2!C2=Export1!$C$2:$C$8),0),1),"")
Worksheet: ResIndex2

[DocAElstein]

In suppot of this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35600


' http://www.eileenslounge.com/viewtopic.php?f=30&t=35600
Sub ConvertBytesToString1()
Dim Ay() As Variant: Let Ay() = Array(89, 97, 115, 115, 101, 114)
Dim Es As String
Dim Spt() As String
Let Spt() = Split(ChrW(1) & "Sp" & ChrW(2) & "Sp" & ChrW(3) & "Sp" & ChrW(4) & "Sp" & ChrW(5) & "Sp" & ChrW(6) & "Sp" & ChrW(7) & "Sp" & ChrW(8) & "Sp" & ChrW(9) & "Sp" & ChrW(10) & "Sp" & ChrW(11) & "Sp" & ChrW(12) & "Sp" & ChrW(13) & "Sp" & ChrW(14) & "Sp" & ChrW(15) & "Sp" & ChrW(16) & "Sp" & ChrW(17) & "Sp" & ChrW(18) & "Sp" & ChrW(19) & "Sp" & ChrW(20) & "Sp" & ChrW(21) & "Sp" & ChrW(22) & "Sp" & ChrW(23) & "Sp" & ChrW(24) & "Sp" & ChrW(25) & "Sp" & ChrW(26) & "Sp" & ChrW(27) & "Sp" & ChrW(28) & "Sp" & ChrW(29) & "Sp" & ChrW(30) & "Sp" & ChrW(31) & "Sp" & ChrW(32) & "Sp" & ChrW(33) & "Sp" & ChrW(34) & "Sp" & ChrW(35) & "Sp" & ChrW(36) & "Sp" & ChrW(37) & "Sp" & ChrW(38) & "Sp" & ChrW(39) & "Sp" & ChrW(40) & "Sp" & ChrW(41) & "Sp" & ChrW(42) & "Sp" & ChrW(43) & "Sp" & ChrW(44) & "Sp" & ChrW(45) & "Sp" & ChrW(46) & "Sp" & ChrW(47) & "Sp" & ChrW(48) & "Sp" & ChrW(49) & "Sp" & ChrW(50) & _
"Sp" & ChrW(51) & "Sp" & ChrW(52) & "Sp" & ChrW(53) & "Sp" & ChrW(54) & "Sp" & ChrW(55) & "Sp" & ChrW(56) & "Sp" & ChrW(57) & "Sp" & ChrW(58) & "Sp" & ChrW(59) & "Sp" & ChrW(60) & "Sp" & ChrW(61) & "Sp" & ChrW(62) & "Sp" & ChrW(63) & "Sp" & ChrW(64) & "Sp" & ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126) & "Sp" & ChrW(127) & "Sp" & ChrW(128) & "Sp" & ChrW(129) & "Sp" & ChrW(130) & "Sp" & ChrW(131) & "Sp" & ChrW(132) & "Sp" & ChrW(133) & "Sp" & ChrW(134) & "Sp" & ChrW(135) & "Sp" & ChrW(136) & "Sp" & ChrW(137) & "Sp" & ChrW(138) & "Sp" & ChrW(139) & "Sp" & ChrW(140) & "Sp" & ChrW(141) & "Sp" & ChrW(142) & "Sp" & ChrW(143) & "Sp" & ChrW(144) & "Sp" & ChrW(145) & "Sp" & ChrW(146) & "Sp" & ChrW(147) & "Sp" & ChrW(148) & "Sp" & ChrW(149) & "Sp" & ChrW(150) & _
"Sp" & ChrW(151) & "Sp" & ChrW(152) & "Sp" & ChrW(153) & "Sp" & ChrW(154) & "Sp" & ChrW(155) & "Sp" & ChrW(156) & "Sp" & ChrW(157) & "Sp" & ChrW(158) & "Sp" & ChrW(159) & "Sp" & ChrW(160) & "Sp" & ChrW(161) & "Sp" & ChrW(162) & "Sp" & ChrW(163) & "Sp" & ChrW(164) & "Sp" & ChrW(165) & "Sp" & ChrW(166) & "Sp" & ChrW(167) & "Sp" & ChrW(168) & "Sp" & ChrW(169) & "Sp" & ChrW(170) & "Sp" & ChrW(171) & "Sp" & ChrW(172) & "Sp" & ChrW(173) & "Sp" & ChrW(174) & "Sp" & ChrW(175) & "Sp" & ChrW(176) & "Sp" & ChrW(177) & "Sp" & ChrW(178) & "Sp" & ChrW(179) & "Sp" & ChrW(180) & "Sp" & ChrW(181) & "Sp" & ChrW(182) & "Sp" & ChrW(183) & "Sp" & ChrW(184) & "Sp" & ChrW(185) & "Sp" & ChrW(186) & "Sp" & ChrW(187) & "Sp" & ChrW(188) & "Sp" & ChrW(189) & "Sp" & ChrW(190) & "Sp" & ChrW(191) & "Sp" & ChrW(192) & "Sp" & ChrW(193) & "Sp" & ChrW(194) & "Sp" & ChrW(195) & "Sp" & ChrW(196) & "Sp" & ChrW(197) & "Sp" & ChrW(198) & "Sp" & ChrW(199) & "Sp" & ChrW(200), "Sp")
' Let Range("A2").Resize(1, 200) = Spt()
Let Es = Join(Application.Index(Spt(), 1, Ay), "")
' Or
Let Es = Join(Application.Index(Split(ChrW(1) & "Sp" & ChrW(2) & "Sp" & ChrW(3) & "Sp" & ChrW(4) & "Sp" & ChrW(5) & "Sp" & ChrW(6) & "Sp" & ChrW(7) & "Sp" & ChrW(8) & "Sp" & ChrW(9) & "Sp" & ChrW(10) & "Sp" & ChrW(11) & "Sp" & ChrW(12) & "Sp" & ChrW(13) & "Sp" & ChrW(14) & "Sp" & ChrW(15) & "Sp" & ChrW(16) & "Sp" & ChrW(17) & "Sp" & ChrW(18) & "Sp" & ChrW(19) & "Sp" & ChrW(20) & "Sp" & ChrW(21) & "Sp" & ChrW(22) & "Sp" & ChrW(23) & "Sp" & ChrW(24) & "Sp" & ChrW(25) & "Sp" & ChrW(26) & "Sp" & ChrW(27) & "Sp" & ChrW(28) & "Sp" & ChrW(29) & "Sp" & ChrW(30) & "Sp" & ChrW(31) & "Sp" & ChrW(32) & "Sp" & ChrW(33) & "Sp" & ChrW(34) & "Sp" & ChrW(35) & "Sp" & ChrW(36) & "Sp" & ChrW(37) & "Sp" & ChrW(38) & "Sp" & ChrW(39) & "Sp" & ChrW(40) & "Sp" & ChrW(41) & "Sp" & ChrW(42) & "Sp" & ChrW(43) & "Sp" & ChrW(44) & "Sp" & ChrW(45) & "Sp" & ChrW(46) & "Sp" & ChrW(47) & "Sp" & ChrW(48) & "Sp" & ChrW(49) & "Sp" & ChrW(50) & _
"Sp" & ChrW(51) & "Sp" & ChrW(52) & "Sp" & ChrW(53) & "Sp" & ChrW(54) & "Sp" & ChrW(55) & "Sp" & ChrW(56) & "Sp" & ChrW(57) & "Sp" & ChrW(58) & "Sp" & ChrW(59) & "Sp" & ChrW(60) & "Sp" & ChrW(61) & "Sp" & ChrW(62) & "Sp" & ChrW(63) & "Sp" & ChrW(64) & "Sp" & ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126) & "Sp" & ChrW(127) & "Sp" & ChrW(128) & "Sp" & ChrW(129) & "Sp" & ChrW(130) & "Sp" & ChrW(131) & "Sp" & ChrW(132) & "Sp" & ChrW(133) & "Sp" & ChrW(134) & "Sp" & ChrW(135) & "Sp" & ChrW(136) & "Sp" & ChrW(137) & "Sp" & ChrW(138) & "Sp" & ChrW(139) & "Sp" & ChrW(140) & "Sp" & ChrW(141) & "Sp" & ChrW(142) & "Sp" & ChrW(143) & "Sp" & ChrW(144) & "Sp" & ChrW(145) & "Sp" & ChrW(146) & "Sp" & ChrW(147) & "Sp" & ChrW(148) & "Sp" & ChrW(149) & "Sp" & ChrW(150) & _
"Sp" & ChrW(151) & "Sp" & ChrW(152) & "Sp" & ChrW(153) & "Sp" & ChrW(154) & "Sp" & ChrW(155) & "Sp" & ChrW(156) & "Sp" & ChrW(157) & "Sp" & ChrW(158) & "Sp" & ChrW(159) & "Sp" & ChrW(160) & "Sp" & ChrW(161) & "Sp" & ChrW(162) & "Sp" & ChrW(163) & "Sp" & ChrW(164) & "Sp" & ChrW(165) & "Sp" & ChrW(166) & "Sp" & ChrW(167) & "Sp" & ChrW(168) & "Sp" & ChrW(169) & "Sp" & ChrW(170) & "Sp" & ChrW(171) & "Sp" & ChrW(172) & "Sp" & ChrW(173) & "Sp" & ChrW(174) & "Sp" & ChrW(175) & "Sp" & ChrW(176) & "Sp" & ChrW(177) & "Sp" & ChrW(178) & "Sp" & ChrW(179) & "Sp" & ChrW(180) & "Sp" & ChrW(181) & "Sp" & ChrW(182) & "Sp" & ChrW(183) & "Sp" & ChrW(184) & "Sp" & ChrW(185) & "Sp" & ChrW(186) & "Sp" & ChrW(187) & "Sp" & ChrW(188) & "Sp" & ChrW(189) & "Sp" & ChrW(190) & "Sp" & ChrW(191) & "Sp" & ChrW(192) & "Sp" & ChrW(193) & "Sp" & ChrW(194) & "Sp" & ChrW(195) & "Sp" & ChrW(196) & "Sp" & ChrW(197) & "Sp" & ChrW(198) & "Sp" & ChrW(199) & "Sp" & ChrW(200), "Sp"), 1, Ay), "")
End Sub

[DocAElstein]

In support of this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35600


Sub ConvertBytesToString2()
Dim Es As String
Dim Spt() As String
Let Spt() = Split(ChrW(1) & "Sp" & ChrW(2) & "Sp" & ChrW(3) & "Sp" & ChrW(4) & "Sp" & ChrW(5) & "Sp" & ChrW(6) & "Sp" & ChrW(7) & "Sp" & ChrW(8) & "Sp" & ChrW(9) & "Sp" & ChrW(10) & "Sp" & ChrW(11) & "Sp" & ChrW(12) & "Sp" & ChrW(13) & "Sp" & ChrW(14) & "Sp" & ChrW(15) & "Sp" & ChrW(16) & "Sp" & ChrW(17) & "Sp" & ChrW(18) & "Sp" & ChrW(19) & "Sp" & ChrW(20) & "Sp" & ChrW(21) & "Sp" & ChrW(22) & "Sp" & ChrW(23) & "Sp" & ChrW(24) & "Sp" & ChrW(25) & "Sp" & ChrW(26) & "Sp" & ChrW(27) & "Sp" & ChrW(28) & "Sp" & ChrW(29) & "Sp" & ChrW(30) & "Sp" & ChrW(31) & "Sp" & ChrW(32) & "Sp" & ChrW(33) & "Sp" & ChrW(34) & "Sp" & ChrW(35) & "Sp" & ChrW(36) & "Sp" & ChrW(37) & "Sp" & ChrW(38) & "Sp" & ChrW(39) & "Sp" & ChrW(40) & "Sp" & ChrW(41) & "Sp" & ChrW(42) & "Sp" & ChrW(43) & "Sp" & ChrW(44) & "Sp" & ChrW(45) & "Sp" & ChrW(46) & "Sp" & ChrW(47) & "Sp" & ChrW(48) & "Sp" & ChrW(49) & "Sp" & ChrW(50) & _
"Sp" & ChrW(51) & "Sp" & ChrW(52) & "Sp" & ChrW(53) & "Sp" & ChrW(54) & "Sp" & ChrW(55) & "Sp" & ChrW(56) & "Sp" & ChrW(57) & "Sp" & ChrW(58) & "Sp" & ChrW(59) & "Sp" & ChrW(60) & "Sp" & ChrW(61) & "Sp" & ChrW(62) & "Sp" & ChrW(63) & "Sp" & ChrW(64) & "Sp" & ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126) & "Sp" & ChrW(127) & "Sp" & ChrW(128) & "Sp" & ChrW(129) & "Sp" & ChrW(130) & "Sp" & ChrW(131) & "Sp" & ChrW(132) & "Sp" & ChrW(133) & "Sp" & ChrW(134) & "Sp" & ChrW(135) & "Sp" & ChrW(136) & "Sp" & ChrW(137) & "Sp" & ChrW(138) & "Sp" & ChrW(139) & "Sp" & ChrW(140) & "Sp" & ChrW(141) & "Sp" & ChrW(142) & "Sp" & ChrW(143) & "Sp" & ChrW(144) & "Sp" & ChrW(145) & "Sp" & ChrW(146) & "Sp" & ChrW(147) & "Sp" & ChrW(148) & "Sp" & ChrW(149) & "Sp" & ChrW(150) & _
"Sp" & ChrW(151) & "Sp" & ChrW(152) & "Sp" & ChrW(153) & "Sp" & ChrW(154) & "Sp" & ChrW(155) & "Sp" & ChrW(156) & "Sp" & ChrW(157) & "Sp" & ChrW(158) & "Sp" & ChrW(159) & "Sp" & ChrW(160) & "Sp" & ChrW(161) & "Sp" & ChrW(162) & "Sp" & ChrW(163) & "Sp" & ChrW(164) & "Sp" & ChrW(165) & "Sp" & ChrW(166) & "Sp" & ChrW(167) & "Sp" & ChrW(168) & "Sp" & ChrW(169) & "Sp" & ChrW(170) & "Sp" & ChrW(171) & "Sp" & ChrW(172) & "Sp" & ChrW(173) & "Sp" & ChrW(174) & "Sp" & ChrW(175) & "Sp" & ChrW(176) & "Sp" & ChrW(177) & "Sp" & ChrW(178) & "Sp" & ChrW(179) & "Sp" & ChrW(180) & "Sp" & ChrW(181) & "Sp" & ChrW(182) & "Sp" & ChrW(183) & "Sp" & ChrW(184) & "Sp" & ChrW(185) & "Sp" & ChrW(186) & "Sp" & ChrW(187) & "Sp" & ChrW(188) & "Sp" & ChrW(189) & "Sp" & ChrW(190) & "Sp" & ChrW(191) & "Sp" & ChrW(192) & "Sp" & ChrW(193) & "Sp" & ChrW(194) & "Sp" & ChrW(195) & "Sp" & ChrW(196) & "Sp" & ChrW(197) & "Sp" & ChrW(198) & "Sp" & ChrW(199) & "Sp" & ChrW(200), "Sp")
Let Es = Join(Application.Index(Spt(), 1, Evaluate("={89, 97, 115, 115, 101, 114}")), "")
' Or
Let Es = Join(Application.Index(Split(ChrW(1) & "Sp" & ChrW(2) & "Sp" & ChrW(3) & "Sp" & ChrW(4) & "Sp" & ChrW(5) & "Sp" & ChrW(6) & "Sp" & ChrW(7) & "Sp" & ChrW(8) & "Sp" & ChrW(9) & "Sp" & ChrW(10) & "Sp" & ChrW(11) & "Sp" & ChrW(12) & "Sp" & ChrW(13) & "Sp" & ChrW(14) & "Sp" & ChrW(15) & "Sp" & ChrW(16) & "Sp" & ChrW(17) & "Sp" & ChrW(18) & "Sp" & ChrW(19) & "Sp" & ChrW(20) & "Sp" & ChrW(21) & "Sp" & ChrW(22) & "Sp" & ChrW(23) & "Sp" & ChrW(24) & "Sp" & ChrW(25) & "Sp" & ChrW(26) & "Sp" & ChrW(27) & "Sp" & ChrW(28) & "Sp" & ChrW(29) & "Sp" & ChrW(30) & "Sp" & ChrW(31) & "Sp" & ChrW(32) & "Sp" & ChrW(33) & "Sp" & ChrW(34) & "Sp" & ChrW(35) & "Sp" & ChrW(36) & "Sp" & ChrW(37) & "Sp" & ChrW(38) & "Sp" & ChrW(39) & "Sp" & ChrW(40) & "Sp" & ChrW(41) & "Sp" & ChrW(42) & "Sp" & ChrW(43) & "Sp" & ChrW(44) & "Sp" & ChrW(45) & "Sp" & ChrW(46) & "Sp" & ChrW(47) & "Sp" & ChrW(48) & "Sp" & ChrW(49) & "Sp" & ChrW(50) & _
"Sp" & ChrW(51) & "Sp" & ChrW(52) & "Sp" & ChrW(53) & "Sp" & ChrW(54) & "Sp" & ChrW(55) & "Sp" & ChrW(56) & "Sp" & ChrW(57) & "Sp" & ChrW(58) & "Sp" & ChrW(59) & "Sp" & ChrW(60) & "Sp" & ChrW(61) & "Sp" & ChrW(62) & "Sp" & ChrW(63) & "Sp" & ChrW(64) & "Sp" & ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126) & "Sp" & ChrW(127) & "Sp" & ChrW(128) & "Sp" & ChrW(129) & "Sp" & ChrW(130) & "Sp" & ChrW(131) & "Sp" & ChrW(132) & "Sp" & ChrW(133) & "Sp" & ChrW(134) & "Sp" & ChrW(135) & "Sp" & ChrW(136) & "Sp" & ChrW(137) & "Sp" & ChrW(138) & "Sp" & ChrW(139) & "Sp" & ChrW(140) & "Sp" & ChrW(141) & "Sp" & ChrW(142) & "Sp" & ChrW(143) & "Sp" & ChrW(144) & "Sp" & ChrW(145) & "Sp" & ChrW(146) & "Sp" & ChrW(147) & "Sp" & ChrW(148) & "Sp" & ChrW(149) & "Sp" & ChrW(150) & _
"Sp" & ChrW(151) & "Sp" & ChrW(152) & "Sp" & ChrW(153) & "Sp" & ChrW(154) & "Sp" & ChrW(155) & "Sp" & ChrW(156) & "Sp" & ChrW(157) & "Sp" & ChrW(158) & "Sp" & ChrW(159) & "Sp" & ChrW(160) & "Sp" & ChrW(161) & "Sp" & ChrW(162) & "Sp" & ChrW(163) & "Sp" & ChrW(164) & "Sp" & ChrW(165) & "Sp" & ChrW(166) & "Sp" & ChrW(167) & "Sp" & ChrW(168) & "Sp" & ChrW(169) & "Sp" & ChrW(170) & "Sp" & ChrW(171) & "Sp" & ChrW(172) & "Sp" & ChrW(173) & "Sp" & ChrW(174) & "Sp" & ChrW(175) & "Sp" & ChrW(176) & "Sp" & ChrW(177) & "Sp" & ChrW(178) & "Sp" & ChrW(179) & "Sp" & ChrW(180) & "Sp" & ChrW(181) & "Sp" & ChrW(182) & "Sp" & ChrW(183) & "Sp" & ChrW(184) & "Sp" & ChrW(185) & "Sp" & ChrW(186) & "Sp" & ChrW(187) & "Sp" & ChrW(188) & "Sp" & ChrW(189) & "Sp" & ChrW(190) & "Sp" & ChrW(191) & "Sp" & ChrW(192) & "Sp" & ChrW(193) & "Sp" & ChrW(194) & "Sp" & ChrW(195) & "Sp" & ChrW(196) & "Sp" & ChrW(197) & "Sp" & ChrW(198) & "Sp" & ChrW(199) & "Sp" & ChrW(200), "Sp"), 1, Evaluate("={89, 97, 115, 115, 101, 114}")), "")
End Sub

[DocAElstein]

In support of this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35600



' If I don't need all characters, then I can simplify a bit
Sub ConvertBytesToString3()
Dim Es As String
Dim Spt() As String
Let Spt() = Split(ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126), "Sp")
Let Es = Join(Application.Index(Spt(), 1, Evaluate("={89, 97, 115, 115, 101, 114}-64")), "")
' Or
Let Es = Join(Application.Index(Split(ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126), "Sp"), 1, Evaluate("={89, 97, 115, 115, 101, 114}-64")), "")
End Sub

Sub ConvertBytesToString4()
Dim Es As String
Dim Splat() As Variant
Let Splat() = Array(ChrW(65), ChrW(66), ChrW(67), ChrW(68), ChrW(69), ChrW(70), ChrW(71), ChrW(72), ChrW(73), ChrW(74), ChrW(75), ChrW(76), ChrW(77), ChrW(78), ChrW(79), ChrW(80), ChrW(81), ChrW(82), ChrW(83), ChrW(84), ChrW(85), ChrW(86), ChrW(87), ChrW(88), ChrW(89), ChrW(90), ChrW(91), ChrW(92), ChrW(93), ChrW(94), ChrW(95), ChrW(96), ChrW(97), ChrW(98), ChrW(99), ChrW(100), ChrW(101), ChrW(102), ChrW(103), ChrW(104), ChrW(105), ChrW(106), ChrW(107), ChrW(108), ChrW(109), ChrW(110), ChrW(111), ChrW(112), ChrW(113), ChrW(114), ChrW(115), ChrW(116), ChrW(117), ChrW(118), ChrW(119), ChrW(120), ChrW(121), ChrW(122), ChrW(123), ChrW(124), ChrW(125), ChrW(126))
Let Es = Join(Application.Index(Splat(), 1, Evaluate("={89, 97, 115, 115, 101, 114}-64")), "")
' Or
Let Es = Join(Application.Index(Array(ChrW(65), ChrW(66), ChrW(67), ChrW(68), ChrW(69), ChrW(70), ChrW(71), ChrW(72), ChrW(73), ChrW(74), ChrW(75), ChrW(76), ChrW(77), ChrW(78), ChrW(79), ChrW(80), ChrW(81), ChrW(82), ChrW(83), ChrW(84), ChrW(85), ChrW(86), ChrW(87), ChrW(88), ChrW(89), ChrW(90), ChrW(91), ChrW(92), ChrW(93), ChrW(94), ChrW(95), ChrW(96), ChrW(97), ChrW(98), ChrW(99), ChrW(100), ChrW(101), ChrW(102), ChrW(103), ChrW(104), ChrW(105), ChrW(106), ChrW(107), ChrW(108), ChrW(109), ChrW(110), ChrW(111), ChrW(112), ChrW(113), ChrW(114), ChrW(115), ChrW(116), ChrW(117), ChrW(118), ChrW(119), ChrW(120), ChrW(121), ChrW(122), ChrW(123), ChrW(124), ChrW(125), ChrW(126)), 1, Evaluate("={89, 97, 115, 115, 101, 114}-64")), "")
End Sub

[DocAElstein]

In support of this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35600




Sub MakeSomeStringsToCopyAndPasteIntoACode()
Dim CodeText As String
Dim Cnt As Long
Rem 1 For an ASCII array from Split
'1a) Spaces : Note: PROBLEM* If you use the Split way, then best is to avoid using a single character as the separator. Otherwise you may have problems if you want that character in your Horizontal Array of ASCII characters because it will be seen as a separator for Split. This means that you will not get that character in your list. Instead you will have 2 extra empty elements in your array, and all characters after where the character ( here the space) should have been will appear offset by one place to the right in the horizontal array
For Cnt = 1 To 200
Let CodeText = CodeText & " & "" "" & ChrW(" & Cnt & ")"
Next Cnt
Let CodeText = Mid(CodeText, 10) ' take of first 9 bits of Space&Space"Space"Space&Space
Debug.Print CodeText
Debug.Print
Let CodeText = "" ' Empty so that i can use the varable again below
'1b) Use any 2 characters as the seperator to avoid PROBLEM*
For Cnt = 1 To 200
Let CodeText = CodeText & " & ""Sp"" & ChrW(" & Cnt & ")"
Next Cnt
Let CodeText = Mid(CodeText, 11) ' take of first 10 bits of Space&Space"Sp"Space&Space
Debug.Print CodeText
Debug.Print
Rem 2 For ASCII array from VBA Array( ) function
Let CodeText = "" ' Empty so that i can use the varable again below
For Cnt = 1 To 200
Let CodeText = CodeText & ", ChrW(" & Cnt & ")"
Next Cnt
Let CodeText = Mid(CodeText, 3) ' take off the first two characters " ,"
Debug.Print CodeText
Debug.Print
End Sub
' http://www.eileenslounge.com/viewtopic.php?f=30&t=35600

[DocAElstein]

Test post for later use

[DocAElstein]

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559




On Error GoTo -1 is not equivalent of using Err.Clear. It does ( also) clear the error object, (equivalent of using Err.Clear ).
On Error GoTo -1 takes Excel out of the so called “exception state”. It also does clear the Err object registers, (equivalent of using Err.Clear ). But the later is secondary to its main function of “clearing the exception”.
The next macro has 3 identical erroring code lines . Just before each error we have an error handler, which we might expect would trap the error following it . All three error handlers are similar and are of the type On Error GoTo [LABEL] But we find that only the first two error handlers work….
In this macro the first and the second error handlers, of the type On Error GoTo [LABEL] are enabled, and so when an error occurs the coding jumps to the appropriate Label
The second Error handler would not have worked, that is to say the second error would not have been trapped without the code line of On Error GoTo -1 . On Error GoTo -1 has cleared the exception state.
The third error handler, also of the type On Error GoTo [LABEL], does not work. It does not work, that is to say the error is not trapped , because we are in the exception state. One of the characteristics of the exception state is that any attempt to enable an error handler will be ignored. Another characteristic of the exception state is that any enabled error handler, ( in this case the second one ) , will also be ignored.
It is also sometimes said in this situation that the second error handler is active and is still handling the second error. It cannot handle another error , and any further errors will be handled by the VBA default error handler

Sub OnErrorGoToMinus1_takes_Excel_out_of_the_so_called _exception_state() ' It also does clear the Err object registers, (equivalent of using Err.Clear ). But the later is secondary to its main function of "clearing the exception"
Dim Rslt As Double

On Error GoTo ErrHndlr1
Let Rslt = 1 / 0 ' This error gets trapped by ErrHndlr1
MsgBox Prompt:="You will never see this", Title:="You will never see this"
Exit Sub ' You will never come here in this demo macro, but its good practice to get in the habit of always doing this exit sub

ErrHndlr1:
Debug.Print Err.Number & vbCr & vbLf & Err.Description ' 11 Division durch Null
On Error GoTo -1 ' the next line will give us no error infomation because the On Error GoTo -1 has cleared the Err object registers
Debug.Print Err.Number & vbCr & vbLf & Err.Description ' 0

On Error GoTo ErrHndlr2 ' the main function of On Error GoTo -1 is to "clear the exception" which means this second error hanhler will work
Let Rslt = 1 / 0 ' This error gets trapped by ErrHndlr2
MsgBox Prompt:="You will never see this", Title:="You will never see this"
Exit Sub ' You will never come here in this demo macro, but its good practice to get in the habit of always doing this exit sub

ErrHndlr2:
Debug.Print Err.Number & vbCr & vbLf & Err.Description ' 11 Division durch Null
' I will not do On Error GoTo -1 and see what happens...

On Error GoTo ErrHndlr3
Let Rslt = 1 / 0 ' This will be handled by the VBA default error handler: The error will not be trapped by the second error handler , ErrHndlr2
MsgBox Prompt:="You will never see this", Title:="You will never see this"
Exit Sub ' You will never come here in this demo macro, but its good practice to get in the habit of always doing this exit sub

ErrHndlr3:
' You will never come here. The third error is not trapped: It will be handled by the VBA default error handler

End Sub

The following other error things also , in addition to their main function, clear the Err object registers –
_ On Error GoTo 0 ,
_ changing the error handler
_ Resume, ( Resume; Resume Next; Resume [label] )
-.....see next post

[DocAElstein]

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559


_.....continued from last post

The following other error things also , in addition to their main function, clear the Err object registers –
_ On Error GoTo 0 ,
_ changing the error handler
_ Resume, ( Resume; Resume Next; Resume [label] ) ,
Here are 5 demos
1x On Error GoTo 0
1x changing the error handler
3x Resume, ( 1xResume; 1xResume Next; 1xResume [label] )

Sub OnErrorGoTo0ClearsErr() ' _ On Error GoTo 0
Dim Rslt As Double
On Error Resume Next ' In simple terms this allows the code to contiunue as if no error had occured. It is not quite that simple, for example, the Err and Error are filled
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / 0
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null
On Error GoTo 0 ' The main purpose of this is to disable our error handler and return to the default VBA error handler. As a secodary function it seems to clear the Err registers
Debug.Print Err & vbCr & vbLf & Error ' gives 0
End Sub

Sub ChangingTheErrorHandlerClearsErr() ' _ changing the error handler
Dim Rslt As Double
On Error Resume Next ' In simple terms this allows the code to contiunue as if no error had occured. It is not quite that simple, for example, the Err and Error are filled
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / 0
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null
On Error Resume Next
Debug.Print Err & vbCr & vbLf & Error ' gives 0 because I have changed the error handler , ( admitedly in this case changed it to the same type )
Let Rslt = 1 / 0
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null
On Error GoTo Bed
Debug.Print Err & vbCr & vbLf & Error ' gives 0 because I have changed the error handler
Let Rslt = 1 / 0
Exit Sub ' I don't need this since i never come here, but its good practice to get in the habit of having this above a typical Error handling code section.
Bed:
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null
End Sub

Sub Resume_ClearsErr() ' _ Resume, ( Resume )
Dim Rslt As Double, Demonostrator As Long
On Error GoTo ErrHndler ' In simple terms this tells VBA to go the the label, ErrHndler Note however that if an error causes me to go there, then I will then be in the exception state.
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / Demonostrator ' Initially this causes me to go to ErrHndler but then the Resume brings me back to re try this code line
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The Resume cleared the Err registers
Exit Sub

ErrHndler: ' Start of a what is commonly called an "error handling code section"
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
Let Demonostrator = 1 ' It is important to cure the problem causing the error here, or otherwise the next code line will cause an infinite loop because the next code line instructs VBA to go back and try the erroring code line again. Note also that the Resume in the next code line also clears the error exception and clears the Err registers
Resume ' This clears the exception, clears the Err registers, and instructs VBA to go back to the code line that errored and try again. Because it instructs VBA to go back and try the erroring code line again, It is important to cure the problem causing the error before this code line, or else we will have an infinite loop
End Sub
Sub Resume_Next_ClearsErr() ' 'Resume, ( Resume Next )
Dim Rslt As Double
On Error GoTo ErrHndler ' In simple terms this tells VBA to go the the label, ErrHndler Note however that if an error causes me to go there, then I will then be in the exception state.
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / 0 ' This causes me to go to ErrHndler The Resume Next brings me back to just after this code line
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The Resume Next cleared the Err registers
Exit Sub

ErrHndler: ' Start of a what is commonly called an "error handling code section"
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
Resume Next ' This clears the exception, clears the Err registers, and instructs VBA to go back to the code line just after that code line that errored
End Sub
Sub Resume_LABEL_ClearsErr() ' 'Resume, ( Resume [label] )
Dim Rslt As Double
On Error GoTo ErrHndler ' In simple terms this tells VBA to go the the label, ErrHndler Note however that if an error causes me to go there, then I will then be in the exception state.
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / 0 ' This causes me to go to ErrHndler The Resume Lbl brings me back to just after the label, Lbl:

Lbl:
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The Resume Lbl cleared the Err registers
Exit Sub

ErrHndler: ' Start of what is commonly called an "error handling code section"
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
Resume Lbl ' This clears the exception, clears the Err registers, and instructs VBA to go to the code line just after the label Lbl:
End Sub

If we use On Error GoTo [LABEL] and then use Resume ( Resume; Resume Next; Resume [label] ) then we appear to be having something done very similar, or possibly exactly the same as On Error GoTo -1 , since the exception state is cleared and the Err object is cleared.
To demonstrate this we can do the last three routines again, and simply add another error handler , for example On Error Resume Next , after the return point, and follow this by an error. If the error is handled, that is to say we get no default VBA error message, then we know that the exception had been cleared previously. If it had not been cleared then the new error handler, On Error Resume Next , would have been ignored and we would have seen the default VBA error handler warning pop up message.

_..... continued in next post

[DocAElstein]

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559


_.... from last post

If we use On Error GoTo [LABEL] and then use Resume ( Resume; Resume Next; Resume [label] ) then we appear to be having something done very similar, or possibly exactly the same as On Error GoTo -1 , since the exception state is cleared and the Err object is cleared.
To demonstrate this we can do the last three routines again, and simply add another error handler , for example On Error Resume Next , after the return point, and follow this by an error. If the error is handled, that is to say we get no default VBA error message, then we know that the exception had been cleared previously. If it had not been cleared then the new error handler, On Error Resume Next , would have been ignored and we would have seen the default VBA error handler warning pop up message.



' If we use On Error GoTo [LABEL] and then use Resume ( Resume; Resume Next; Resume [label] ) then we appear to be having something done very similar, or possibly exactly the same as On Error GoTo -1 , since the exception state is cleared and the Err object is cleared.
Sub Resume_ClearsErr_() ' _ Resume, ( Resume )
Dim Rslt As Double, Demonostrator As Long
On Error GoTo ErrHndler
Debug.Print Err & vbCr & vbLf & Error
Let Rslt = 1 / Demonostrator
Debug.Print Err & vbCr & vbLf & Error
On Error Resume Next ' This would be ignored if I was in exception state.
Let Rslt = 1 / 0 ' This does not give us an error , so the last code line worked, indicating that we were not in exception state
On Error GoTo 0 ' I do not need to do this since I am Exiting Sub in next code line. But it is good practice to get in the habit of doing this to return to normnal default VBA error handling if i know i am finished using the Error handler which I enabled
Exit Sub

ErrHndler:
Debug.Print Err & vbCr & vbLf & Error
Let Demonostrator = 1
Resume
End Sub
Sub Resume_Next_ClearsErr_() ' 'Resume, ( Resume Next )
Dim Rslt As Double
On Error GoTo ErrHndler
Debug.Print Err & vbCr & vbLf & Error
Let Rslt = 1 / 0
Debug.Print Err & vbCr & vbLf & Error
On Error Resume Next ' This would be ignored if I was in exception state.
Let Rslt = 1 / 0 ' This does not give us an error , so the last code line worked, indicating that we were not in exception state
On Error GoTo 0 ' I do not need to do this since I am Exiting Sub in next code line. But it is good practice to get in the habit of doing this to return to normnal default VBA error handling if i know i am finished using the Error handler which I enabled
Exit Sub

ErrHndler:
Debug.Print Err & vbCr & vbLf & Error
Resume Next
End Sub
Sub Resume_LABEL_ClearsErr_() ' 'Resume, ( Resume [label] )
Dim Rslt As Double
On Error GoTo ErrHndler
Debug.Print Err & vbCr & vbLf & Error
Let Rslt = 1 / 0

Lbl:
Debug.Print Err & vbCr & vbLf & Error
On Error Resume Next ' This would be ignored if I was in exception state.
Let Rslt = 1 / 0 ' This does not give us an error , so the last code line worked, indicating that we were not in exception state
On Error GoTo 0 ' I do not need to do this since I am Exiting Sub in next code line. But it is good practice to get in the habit of doing this to return to normnal default VBA error handling if i know i am finished using the Error handler which I enabled
Exit Sub

ErrHndler:
Debug.Print Err & vbCr & vbLf & Error
Resume Lbl
End Sub

[DocAElstein]

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559


As far as I can tell , the Err object is always filled with information about the last error that occurred, and it seems to me that its sole purpose is to have information about the last error. It can be cleared with Err.Clear , and , is also cleared as a secondary function of other things, including On Error GoTo -1
( In fact it appears the Err is actually a function or an object, possibly working like something similar to Range(xx) which can be regarded as an object or property or function depending on how you use it. We can probably say that Err is a function which returns the Err object. I think that possibly Error is also a similar function. I am not sure exactly what it does, but one thing it does is return the same as Err.Decription, so it can be used in place of Err.Description )

The main purpose of On Error GoTo -1 is to take Excel out of the exception state. The exception state is generally caused by an error occurring. An exception to this being , possibly, of when On Error Resume Next is used: But this is not clear to anyone, as far as I can tell: Its not clear whether
either:
On Error Resume Next prevents the excepting state occurring
or
On Error Resume Next cause the exception state to be cleared immediately after an error occurs.

If On Error Resume Next is used and an error occurs, then something similar to doing On Error GoTo -1 happens. But it is not exactly the same, since the Err object is not cleared, as it is by On Error GoTo -1

Sub OnErrorResumeNext() ' If On Error Resume Next is used and an error occurs, then something similar to doing On Error GoTo -1 happens. But it is not exactly the same, since the Err object is not cleared, as it is by On Error GoTo -1
Dim Rslt As Double
On Error Resume Next
Let Rslt = 1 / 0 ' It is generally thought that we are not in the exception state, but the next line does tell us what error occured, so the On Error Resume Next has not simply done a On Error GoTo -1 , since On Error GoTo -1 would have resulted inj the Err object being cleared which would mean that the next code line retuned us 0
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
On Error GoTo Bed
Let Rslt = 1 / 0 ' We do not get a VBA default error here. We go to Bed: So the error handler worked indicating that we were not in the exception state
On Error GoTo 0 ' I do not need this or the next code line, but its good to get into the habit of turning off any used error handler and having an Exit Sub above a typiucal endind error handling code section
Exit Sub
Bed:
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
End Sub

[DocAElstein]

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559




The Exceptions State
The concept of the exception state is rarely understood.
The most noticeable effect of the error state is that further errors are dealt with by the default VBA error handling. It’s not relevant whether we are in the so called “error handling block” or not.

This frequently catches people out, in particular in a loop situation when error handling only works once, when they had been expecting it to trap all errors occurring: In the exception state, any enabled error handler won’t work again, and any attempt to use / enable another will be ignored.
( In this exception state, the On Error statement , On Error GoTo 0 , would do its main job of disabling any enabled error handler, but it won’t have any effect directly on anything, because it doesn’t clear the exception state. Its effect would only be noticed if the exception was cleared).

See here:
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
http://www.eileenslounge.com/viewtopic.php?p=278909#p278909
http://www.eileenslounge.com/viewtopic.php?p=278922#p278922

[DocAElstein]

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559


hhfhhsfhhfaskh

[DocAElstein]

macro or this Post:
https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15165&viewfull=1#post15165



Sub ConcatWithStyles() ' https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687
Rem 0a save the formulas, and replace with values
Dim arrFormulas() As Variant
Let arrFormulas() = Range("A1:F1").Formula
Let Range("A1:F1").Value = Range("A1:F1").Value
Dim X As Long, Cell As Range, Text As String, Position As Long
Range("A3").Value = Space(Evaluate("SUM(LEN(A1:F1))+COLUMNS(A1:F1)-1"))
Position = 1
' Application.ScreenUpdating = False
For Each Cell In Range("A1:F1")
With Range("A3")
.Characters(Position, Len(Cell.Value)).Text = Cell.Characters(1, Len(Cell.Value)).Text
For X = 1 To Len(Cell.Value)
With .Characters(Position + X - 1, 1).Font
.Name = Cell.Characters(X, 1).Font.Name
.Size = Cell.Characters(X, 1).Font.Size
.Bold = Cell.Characters(X, 1).Font.Bold
.Italic = Cell.Characters(X, 1).Font.Italic
.Underline = Cell.Characters(X, 1).Font.Underline
.Color = Cell.Characters(X, 1).Font.Color
.Strikethrough = Cell.Characters(X, 1).Font.Strikethrough
.Subscript = Cell.Characters(X, 1).Font.Subscript
.Superscript = Cell.Characters(X, 1).Font.Superscript
.TintAndShade = Cell.Characters(X, 1).Font.TintAndShade
.FontStyle = Cell.Characters(X, 1).Font.FontStyle
End With
Next
End With
Position = Position + Len(Cell.Value) + 1
Next
Application.ScreenUpdating = True
Rem 0b Put the formulas back
Let Range("A1:F1").Formula = arrFormulas()
End Sub

[DocAElstein]

In support of these Thread answers:
' ' https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687 https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15170&viewfull=1#post15170


It was seen ( https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15168&viewfull=1#post15168
https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15167&viewfull=1#post15167 ) when solving the formula in cell issue, that the cells containing the formula can only have a single style for all characters in the cell. So it’s not necessary to loop through the characters in each cell when setting the style in the concatenated string from those cells.


' ' https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687 https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15170&viewfull=1#post15170
Sub ConcatWithStyles3()
Dim RngSel As Range: Set RngSel = Selection: Set RngSel = Range("A1:F1")
Rem 0a save any formulas, and replace with values
Dim arrFormulas() As Variant
Let arrFormulas() = RngSel.Formula ' Assuming wew select more than one cell, we will always be presented by .Value a 2 dimensional array, ( even if it is a single row or single column ) This codel line will error if we are using a selection of one cell, since in that case .Value only returns a single value which VBA syntax does not allow to be assigned to a dynmic array
Dim RwCnt As Long, ClmCnt As Long
' For RwCnt = 1 To RngSel.Rows.Count ' At each row we...._
' For ClmCnt = 1 To RngSel.Columns.Count
' If Left(arrFormulas(RwCnt, ClmCnt), 1) = "=" Then ' case a formula in cell
' Let RngSel.Item(RwCnt, ClmCnt).Value = RngSel.Item(RwCnt, ClmCnt).Value ' replace the formula with its value
' Else
' End If
' Next ClmCnt
' Next RwCnt
Dim RwsCnt As Long, ClmsCnt As Long, Itm As Long, ItmCnt As Long
Let ItmCnt = RngSel.Cells.Count
Let RwsCnt = RngSel.Rows.Count: Let ClmsCnt = RngSel.Columns.Count
For Itm = 1 To ItmCnt
If Left(arrFormulas(Int((Itm - 1) / ClmsCnt) + 1, Int((Itm - 1) / RwsCnt) + 1), 1) = "=" Then ' case a formula in cell
Let RngSel.Item(Itm).Value = RngSel.Item(Itm).Value ' replace the formula with its value
Else
End If
Next Itm

Dim ExChr As Long, ACel As Range, TeExt As String, Position As Long
' Let Range("A3").Value = Space(Evaluate("SUM(LEN(A1:F1))+COLUMNS(A1:F1)-1")) ' This makes a teExt of spaces. The number of spaces is the sum of all the teExt in the cells + one less than the number of cells. This gives us enough characters for all the teExt and a space betweeen them
Let Range("A3").Value = Space(Evaluate("=SUM(LEN(" & RngSel.Address & "))+COLUMNS(" & RngSel.Address & ")-1"))
Let Position = 1
' Let Application.ScreenUpdating = False ' adding this code line may speed the macro up a bit

Let Itm = 0
For Each ACel In RngSel
Let Itm = Itm + 1
With Range("A3") ' The range ( cell ) used for final output of concatenated cell text with styles
'here in next code line we put the characters in...
.Characters(Position, Len(ACel.Value)).Text = ACel.Value ' ACel.Characters(1, Len(ACel.Value)).Text ' ACel.Value This puts the charascters
If Left(arrFormulas(Int((Itm - 1) / ClmsCnt) + 1, Int((Itm - 1) / RwsCnt) + 1), 1) = "=" Then ' We only need to consider the cell style, since individual styles on characters are not possible in a cell with a formula in it
' ....it's not necessary to loop through the characters in each cell when setting the style in the concatenated string from those cells containing formulas
With .Characters(Position, Len(ACel.Value)).Font ' all the characters from the current cell in the final concatenated string
.Name = ACel.Font.Name
.Size = ACel.Font.Size
.Bold = ACel.Font.Bold
.Italic = ACel.Font.Italic
.Underline = ACel.Font.Underline
.Color = ACel.Font.Color
.Strikethrough = ACel.Font.Strikethrough
.Subscript = ACel.Font.Subscript
.Superscript = ACel.Font.Superscript
.TintAndShade = ACel.Font.TintAndShade
.FontStyle = ACel.Font.FontStyle
End With '

Else ' we need to consider all characters in the cell
For ExChr = 1 To Len(ACel.Value) ' We are looping for all the tExt Chraracters in the current cell text
' here in the next With End With section the next character in the final concatenated string is given the styles that it had in the cell it came from
With .Characters(Position + ExChr - 1, 1).Font ' A single character in the final concatenated string
.Name = ACel.Characters(ExChr, 1).Font.Name
.Size = ACel.Characters(ExChr, 1).Font.Size
.Bold = ACel.Characters(ExChr, 1).Font.Bold
.Italic = ACel.Characters(ExChr, 1).Font.Italic
.Underline = ACel.Characters(ExChr, 1).Font.Underline
.Color = ACel.Characters(ExChr, 1).Font.Color
.Strikethrough = ACel.Characters(ExChr, 1).Font.Strikethrough
.Subscript = ACel.Characters(ExChr, 1).Font.Subscript
.Superscript = ACel.Characters(ExChr, 1).Font.Superscript
.TintAndShade = ACel.Characters(ExChr, 1).Font.TintAndShade
.FontStyle = ACel.Characters(ExChr, 1).Font.FontStyle
End With '
Next ExChr
End If
End With
Position = Position + Len(ACel.Value) + 1 ' This takes us to posiion at the end of the current cell text +1 ( +1
Next ACel
Application.ScreenUpdating = True
Rem 0b Put the formulas back
For RwCnt = 1 To RngSel.Rows.Count ' At each row we...._
For ClmCnt = 1 To RngSel.Columns.Count
If Left(arrFormulas(RwCnt, ClmCnt), 1) = "=" Then ' ' case a formula was in cell
Let RngSel.Item(RwCnt, ClmCnt).Formula = arrFormulas(RwCnt, ClmCnt) ' we put the formula back
Else
' we didnt have a formula , so we do nothing to the cell - if we did then we would likely get just one style in the cell - a text with more than one style would revert to one single style throughout
End If
Next ClmCnt
Next RwCnt


End Sub

[DocAElstein]

Coding for this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35980
and this post
https://eileenslounge.com/viewtopic.php?p=279798#p279798

Full version:

Sub Test() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35980
Dim Indx As Long ' the index of the element to be removed - for this example it can be chosen to be 0 or 1 or 2 or 3 or 4
Let Indx = 4

Dim arr1D() As Variant
Let arr1D() = Array(1, 2, 3, 4, 5)
Dim Joint As String
Let Joint = Join(arr1D(), "|"): Debug.Print Joint ' 1|2|3|4|5 ' - make sure you use a seperator that does not appear in any array element
Let Joint = "|" & Joint & "|": Debug.Print Joint ' |1|2|3|4|5| ' - needed so that I can get at the last and first element also
Dim CrackedJoint As String ' For cracked Joint
' I can use Application.WorksheetFunction.Substitute to pick out specific seperators , so I will replace the one before and after with some word like "Crack"
Let CrackedJoint = Application.WorksheetFunction.Substitute(Joint, "|", "Crack2", Indx + 2): Debug.Print CrackedJoint ' |1|2|3|4|5Crack2 ' ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Let CrackedJoint = Application.WorksheetFunction.Substitute(CrackedJo int, "|", "Crack1", Indx + 1): Debug.Print CrackedJoint ' |1|2|3|4Crack15Crack2
Dim Crack1 As Long, Crack2 As Long ' The positions of the cracks
Let Crack1 = InStr(1, CrackedJoint, "Crack1", vbBinaryCompare): Debug.Print Crack1 ' 9
Let Crack2 = InStr(1, CrackedJoint, "Crack2", vbBinaryCompare): Debug.Print Crack2 ' 16
Dim LeftBit As String, RightBit As String
Let LeftBit = Left$(CrackedJoint, Crack1 - 1): Debug.Print LeftBit ' |1|2|3|4
Let RightBit = "|" & Mid$(CrackedJoint, Crack2 + 6): Debug.Print RightBit ' |
Dim JointedJoint As String
Let JointedJoint = LeftBit & RightBit: Debug.Print JointedJoint ' |1|2|3|4|
Let JointedJoint = Mid(JointedJoint, 2, Len(JointedJoint) - 2): Debug.Print JointedJoint ' 1|2|3|4
Dim arr1DOut() As String
Let arr1DOut() = Split(JointedJoint, "|", -1, vbBinaryCompare)
' The above array is of element types of String , so we can't assign that to out original Variant type array. We can convert with
Let arr1D() = Application.Index(arr1DOut(), Evaluate("={1,1,1,1}"), Evaluate("={1,2,3,4}")) ' https://www.excelforum.com/tips-and-tutorials/758402-vba-working-with-areas-within-2d-arrays.html#post5408376
Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:D)/Column(A:D)"), Evaluate("=Column(A:D)")) ' https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5410028
Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '

' or
Let arr1D() = Application.Index(arr1DOut(), 1, 0) '

End Sub




“One liner ( almost ) “ versions


Sub Test2()
Dim Indx As Long
Let Indx = 4

Dim arr1D() As Variant: Let arr1D() = Array(1, 2, 3, 4, 5)
Let arr1D() = Application.Index(Split(Mid(Left$(Application.Work sheetFunction.Substitute(Application.WorksheetFunc tion.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1), 2, Len(Left$(Application.WorksheetFunction.Substitute (Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), _
InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1)) - 2), "|"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '

End Sub






Sub Test3()
Dim Indx As Long
Let Indx = 1

Dim arr1D() As Variant: Let arr1D() = Array(1, 2, 3, 4, 5)
Let arr1D() = Application.Index(Split(Mid(Left$(Application.Work sheetFunction.Substitute(Application.WorksheetFunc tion.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1), 2, Len(Left$(Application.WorksheetFunction.Substitute (Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), _
InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1)) - 2), "|"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '

End Sub


Function version

Sub testFunction()
Dim arr1D() As Variant: Let arr1D() = Array(1, "2", 3, 4, 5)
Let arr1D() = DeleteItem(arr1D(), 1)
End Sub

Function DeleteItem(ByVal Var As Variant, Indx As Long) As Variant
Let DeleteItem = Application.Index(Split(Mid(Left$(Application.Work sheetFunction.Substitute(Application.WorksheetFunc tion.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1), 2, Len(Left$(Application.WorksheetFunction.Substitute (Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), _
InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1)) - 2), "|"), Evaluate("=Column(A:" & Split(Cells(1, UBound(Var)).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(Var)).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(Var)).Address, "$", -1, vbBinaryCompare)(1) & ")")) '
End Function

[DocAElstein]

Coding for this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35980
and this post
https://eileenslounge.com/viewtopic.php?p=279861&sid=880ca3b983884fbedb1ea146e8de06b5#p279861





Sub DeleteItemByIndexIn1DArraySHG1() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35980&p=279809#p279809 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
Dim Indx As Long '
Let Indx = 1 ' 1 is for deleting the first element

Dim arr1D() As Variant
Let arr1D() = Array(1, 2, 3, 4, 5)
Dim Joint As String
Let Joint = Join(arr1D(), ","): Debug.Print Joint ' 1,2,3,4,5 ' - make sure you use a seperator that does not appear in any array element

Dim Pos1 As Long, Pos2 As Long
Let Pos1 = Evaluate("=Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))")
Debug.Print Pos1 ' 1
Let Pos2 = Evaluate("=Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))")
Debug.Print Pos2 ' 3
Dim LeftBit As String, RightBit As String
Let LeftBit = Left$("," & Joint, Pos1 - 1): Debug.Print LeftBit ' nothing there '
Let LeftBit = Evaluate("=Left(""," & Joint & """, " & Pos1 - 1 & ")"): Debug.Print LeftBit ' nothing there
Let RightBit = "," & Mid$("," & Joint & ",", Pos2 + 1): Debug.Print RightBit ' ,2,3,4,5,
' The MID spreadsheet function is less helpful since it must have the third argument ( in VBA MID the third length argument is optional
Let RightBit = "," & Right$("," & Joint & ",", Len(Joint) - (Pos2 - 2)): Debug.Print RightBit ' ,2,3,4,5, ' we don't want to take off the , and Joint is one less than Joint & "," so we take off in total 2 less
Let RightBit = Evaluate("="",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (" & Pos2 - 2 & "))")
Debug.Print RightBit ' ,2,3,4,5, '

Rem Joining the two and trimming odff the leading and trailing seperators
Dim JointedJoint As String
'Let JointedJoint = LeftBit & RightBit: Debug.Print JointedJoint ' ,2,3,4,5,
'Let JointedJoint = Evaluate("=""" & LeftBit & RightBit & """"): Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=" & """" & LeftBit & RightBit & """"): Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=" & """" & LeftBit & ",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (" & Pos2 - 2 & "))")
Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=Left(""," & Joint & """, " & Pos1 - 1 & ")&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (" & Pos2 - 2 & "))")
Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")
Debug.Print JointedJoint ' ,2,3,4,5,

'Let JointedJoint = Mid(JointedJoint, 2, Len(JointedJoint) - 2): Debug.Print JointedJoint ' 2,3,4,5
'Debug.Print JointedJoint ' 2,3,4,5
'Let JointedJoint = Evaluate("=Mid(Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2)),2,Len(Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))))") ' Evaluate string has 355 characters so it wont work
'Debug.Print JointedJoint
Let JointedJoint = Mid(Evaluate("=Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2)
Debug.Print JointedJoint ' 2,3,4,5

' replace Joint with Join(arr1D(), ",")
Let JointedJoint = Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2)
Debug.Print JointedJoint ' 2,3,4,5

' Get the string array back
Dim arr1DOut() As String
Let arr1DOut() = Split(JointedJoint, ",", -1, vbBinaryCompare): Let arr1DOut() = Split(JointedJoint, ",")
Let arr1DOut() = Split(Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2), ",")
' The spilt has returned string Elements, so we can't directly assign to the original array
' Let arr1D() = Application.Index(arr1DOut(), Evaluate("={1,1,1,1}"), Evaluate("={1,2,3,4}")) ' https://www.excelforum.com/tips-and-tutorials/758402-vba-working-with-areas-within-2d-arrays.html#post5408376
' Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:D)/Column(A:D)"), Evaluate("=Column(A:D)")) ' https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5410028
' Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '

' or
' Let arr1D() = Application.Index(arr1DOut(), 1, 0) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%c3%a2%e2%82%ac%e2%80%9c-Application-Index
Let arr1D() = Application.Index(Split(Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2), ","), 1, 0) ' Full workings: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218


End Sub


Or ....

Sub DeleteItemByIndexIn1DArraySHG2() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35980&p=279809#p279809 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
Dim Indx As Long '
Let Indx = 1 ' 1 is for deleting the first element
Dim arr1D() As Variant: Let arr1D() = Array(1, 2, 3, 4, 5)

Let arr1D() = Application.Index(Split(Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2), ","), 1, 0) ' Full workings: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
End Sub


Some explanations in next post

[DocAElstein]

( In this example, Indx, is the Index number of the element that we want to remove starting from 1 – For the first element Indx must be given as 1

In Words , this is how the main code line works…( taking the example of wanting to remove the first element
My 1 D array , for example , {1,2,3,4,5} , is turned into a single text string, “1,2,3,4,5”. ( The separating thing, a comma in this case, is arbitrary. You should choose some character that is not likely to appear in any of your data.)
The next thing to do is add additional leading and trailing separating things ( commas in this example ) , so in the example it would then look like “,1,2,3,4,5,”

Now we use this sort of bit a lot.. Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx +1 & "))
Substitute is used to change the comma before the element you want to some other arbitrary separating thing.
So lets say we used a | and are wanting the first element ( Indx=1 ) removed. We then would have like
“|1,2,3,4,5,”
We then do a Find to get the position of that |
In other words,
The Substitute gives us this "|1,2,3,4,5,"
The Find looks for the | and gives us 1
Substitute is used again to change the comma after the element you want to some other arbitrary separating thing.
So lets say we used a | again. ( we are still wanting the first element) We then would have like
“,1|2,3,4,5,”
We then do a Find to get the position of that |
In other words,
The Substitute gives us this ",1|2,3,4,5,"
The Find looks for that | and gives us 3
Here is the last bit in close to the final code line:

Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2)

So we now know where the start and the end is of the element that we want to remove are
We can use this information to determine the string before, and to determine the string after, the element that we want to remove.
So we put those two strings together and that gives us the original string without the element that we want to remove.
Finally we Split that text back into an array

( Once again we will have all string elements out, regardless of what element types we have in our original array )

[DocAElstein]

post for later use..
http://i.imgur.com/dol9tfQ.jpg
http://i.imgur.com/Ucpj9pZ.jpg
http://i.imgur.com/mtLzChH.jpg
http://i.imgur.com/N2PbR0C.jpg
http://i.imgur.com/Nzfnk90.jpg
http://i.imgur.com/rnYpqNh.jpg
http://i.imgur.com/RODuXQl.jpg
http://i.imgur.com/zpWglC9.jpg


Hello
I tried it , second one, http://i.imgur.com/wL6hN1c.jpg
It did not work

http://i.imgur.com/Z7bl5cc.jpg
http://i.imgur.com/NG2ICxa.jpg
http://i.imgur.com/EpDQOXB.jpg

Alan

[DocAElstein]

post for later use-

[DocAElstein]

post for later use

[DocAElstein]

post for later use

[DocAElstein]

Test...


MID( SUBSTITUTE(Text,Delim,REPT(" ",LEN(Text))) , (element*LEN(Text)) - (LEN(Text)-1) , LEN(Text) )

MID( SUBSTITUTE(Text,Delim,REPT(" ",LEN(Text))) , (element*LEN(Text)) - ( LEN(Text) ) , LEN(Text) )
Row\Col
A
B
C

1
What is pseudo is in the Cell to the left ( column B )


2Example get the first thing, 1 from the Text string "1,3,5"
1,3,5 my original test text


3Length
5the length in characters of my original test text


4( Rept " " ) x Length
5 spaces like "12345"


5Substitute in the original string ( B2 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters


6I apply to B5 the MID function starting at (1x5)-(5-1)=1 and for a length of 5
1____ like "11234"


7I apply to B5 the MID function starting at (1x5)-(5)=0 and for a length of 5
#VALUE!Excel doesn't forgive me for trying to start at 0 !!!!


8



9Example get the second thing, 3 from the Text string "1,3,5"
1,3,5 my original test text


10Length
5the length in characters of my original test text


11( Rept " " ) x Length
5 spaces like "12345"


12Substitute in the original string ( B9 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters


13I apply to B12 the MID function starting at (2x5)-(5-1)=6 and for a length of 5
_3___like "13123"


14I apply to B12 the MID function starting at (2x5)-(5)=5 and for a length of 5
__3__like "12312"


15



16Example get the third thing, 5 from the Text string "1,3,5"
1,3,5 my original test text


17Length
5the length in characters of my original test text


18( Rept " " ) x Length
5 spaces like "12345"


19Substitute in the original string ( B16 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters


20I apply to B19 the MID function starting at (3x5)-(5-1)=11 and for a length of 5
__5like "125" Note: I try to do length 5, but Excel forgives me and gives the 3 it has available


21I apply to B19 the MID function starting at (1x5)-(5)=0 and for a length of 5
___5like "1235" Note: I try to do length 5, but Excel forgives me and gives the 4 it has available

Row\Col
B

1



2
1,3,5


3
=LEN(B2)


4
=REPT(" ",B3)


5
=SUBSTITUTE(B2,",",B4)


6
=MID(B5,(1*B3)-(B3-1),B3)


7
=MID(B5,(1*B3)-(B3),B3)


8



9
1,3,5


10
=LEN(B9)


11
=REPT(" ",B10)


12
=SUBSTITUTE(B9,",",B11)


13
=MID(B12,(2*B10)-(B10-1),B10)


14
=MID(B12,(2*B10)-(B10),B10)


15



16
1,3,5


17
=LEN(B16)


18
=REPT(" ",B17)


19
=SUBSTITUTE(B16,",",B18)


20
=MID(B19,(3*B17)-(B17-1),B17)


21
=MID(B19,(3*B17)-(B17),B17)

Row\Col
A
B
C

7I apply to B5 the MID function starting at (1x5)-(5)=0 and for a length of 5
#VALUE!Excel doesn't forgive me for trying to start at 0 when using MID

[DocAElstein]

Test...


MID( SUBSTITUTE(Text,Delim,REPT(" ",LEN(Text))) , (element*LEN(Text)) - (LEN(Text)-1) , LEN(Text) )

MID( SUBSTITUTE(Text,Delim,REPT(" ",LEN(Text))) , (element*LEN(Text)) - ( LEN(Text) ) , LEN(Text) )
Row\Col
A
B
C

1
What is pseudo is in the Cell to the left ( column B )


2Example get the first thing, 1 from the Text string "1,3,5"
1,3,5 my original test text


3Length
5the length in characters of my original test text


4( Rept " " ) x Length
5 spaces like "12345"


5Substitute in the original string ( B2 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters


6I apply to B5 the MID function starting at (1x5)-(5-1)=1 and for a length of 5
1____ like "11234"


7I apply to B5 the MID function starting at (1x5)-(5)=0 and for a length of 5
#VALUE!Excel doesn't forgive me for trying to start at 0 !!!!


8



9Example get the second thing, 3 from the Text string "1,3,5"
1,3,5 my original test text


10Length
5the length in characters of my original test text


11( Rept " " ) x Length
5 spaces like "12345"


12Substitute in the original string ( B9 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters


13I apply to B12 the MID function starting at (2x5)-(5-1)=6 and for a length of 5
_3___like "13123"


14I apply to B12 the MID function starting at (2x5)-(5)=5 and for a length of 5
__3__like "12312"


15



16Example get the third thing, 5 from the Text string "1,3,5"
1,3,5 my original test text


17Length
5the length in characters of my original test text


18( Rept " " ) x Length
5 spaces like "12345"


19Substitute in the original string ( B16 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters


20I apply to B19 the MID function starting at (3x5)-(5-1)=11 and for a length of 5
__5like "125" Note: I try to do length 5, but Excel forgives me and gives the 3 it has available


21I apply to B19 the MID function starting at (1x5)-(5)=0 and for a length of 5
___5like "1235" Note: I try to do length 5, but Excel forgives me and gives the 4 it has available

Row\Col
B

1



2
1,3,5


3
=LEN(B2)


4
=REPT(" ",B3)


5
=SUBSTITUTE(B2,",",B4)


6
=MID(B5,(1*B3)-(B3-1),B3)


7
=MID(B5,(1*B3)-(B3),B3)


8



9
1,3,5


10
=LEN(B9)


11
=REPT(" ",B10)


12
=SUBSTITUTE(B9,",",B11)


13
=MID(B12,(2*B10)-(B10-1),B10)


14
=MID(B12,(2*B10)-(B10),B10)


15



16
1,3,5


17
=LEN(B16)


18
=REPT(" ",B17)


19
=SUBSTITUTE(B16,",",B18)


20
=MID(B19,(3*B17)-(B17-1),B17)


21
=MID(B19,(3*B17)-(B17),B17)

Row\Col
A
B
C

7I apply to B5 the MID function starting at (1x5)-(5)=0 and for a length of 5
#VALUE!Excel doesn't forgive me for trying to start at 0 when using MID

[DocAElstein]

post to use later

[DocAElstein]

post to use later

[DocAElstein]

In support of this post



Before Source worksheet


_____ Workbook: Transfer data_marasAlan_1.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAH
1NumberUnique IDNameTitlePlatformFilterSalaryAdd1Add2Add3Add4Add 5Add6Add7Add8Add9Add10Add11Add12copy1copy2copy3cop y4copy5copy6copy7Total

433658LaluLeadCFilter23000660606000000011204

92563Vidu_xxManagerJavaFilter240000000000000000812 00121

102563Vidu_maxManagerJavaFilter2425000000000000008 1200222

122563ViduManagerJavaFilter24000000000000000081300 21

162354SaiOperatorC++Filter215000023002000000024000 24

172333FranOperatorSQLFilter21500010000000010000000

183239Jack_maxLeadSQLFilter25660000000450000440840 20

193239JackLeadSQLFilter2300000000046000044484024

234222AndyOperatorJavaFilter2150000000000000040014 826

241123RamManagerJavaFilter240000300000055001200003 15

36126SomOperatorCFilter215000207000000333004060223 2
Worksheet: Sheet1

[DocAElstein]

In support of this post



Before destination worksheet


_____ Workbook: Workbook2_1.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOP
1Unique IDNameTitlePlatformSalarySumcopy1copy2copy3copy4co py5copy6copy7

2
Worksheet: Sheet1


Destination After

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

1
Unique ID
Name
Title
Platform
Salary
Sum
copy1
copy2
copy3
copy4
copy5
copy6
copy7


23658LaluLeadC
£300
24


1
1
2




3563Vidu_xxManagerJava
£400
0


8
12


1


4563Vidu_maxManagerJava
£425
0


8
12


2


5563ViduManagerJava
£400
0


8
13





6354SaiOperatorC++
£150
25


24






7333FranOperatorSQL
£150
2









8239Jack_maxLeadSQL
£566
45
4
4

8
4




9239JackLeadSQL
£300
46
4
4
4
8
4




10222AndyOperatorJava
£150
0

4


14
8



11123RamManagerJava
£400
58
12




3



1226SomOperatorC
£150
342


4

6

22
Worksheet: Sheet1

[DocAElstein]

Macro for last two posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()
Dim a(), arrOut__(), Cls(), Cls_v() As String, Rws(), asum
Dim Rng As Range, Rng_v As Range, Rng_vVls() As Variant, cel As Range
Dim i As Integer, ii As Integer
Dim Pth As String: Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const pth = "c:\Users\User\Downloads\" '<---- use own path
Const wnm = "Workbook2_1.xlsx" 'your workbook name
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = Range("a1:aH" & 36 & "") ' Range("a1:ag" & 36 & "") ' hard coded for testing .UsedRange.Rows.Count)
Let a() = Rng.Value ' The main source data range
Let Cls() = Rng.Rows(1).Value ' The header row
ReDim Rws(1 To UBound(a)) ' The row indicies of the rows we are intersted in from the filtered range ##### this will likely be much too big at this stage but we will correct that later
End With
Rem 2 building a single column array for the summed colums
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' for maras datas this will be 11 data rows and the header 0 12 rows in total
'Rng_vVls() = Rng_v.Value2 ' This is for my testing only - this will give me just first area
If Rng_v.Count > 1 Then
ReDim asum(1 To Rng_v.Count) ' 1 D array to hold sum values - I wanted to sum from column O to column Z and transfer those sum to destination at column I
For Each cel In Rng_v
If cel.Row > 1 And cel.Value <> "" Then
Let ii = ii + 1
Let asum(ii) = Evaluate("sum(o" & cel.Row & ": z" & cel.Row & ")") ' Evaluate Range way to sum a range
Let i = i + 1
Let Rws(i) = cel.Row
End If
Next
If ii > 0 Then ReDim Preserve asum(1 To ii) ' Our array is one element too big with an empty element, so thhis takes off that extra unwanted element
If i > 0 Then ReDim Preserve Rws(1 To i) ' Our array is much too big so this makes it the correct size ####
Else ' case no data rows, only a header row
End If
If Rng_v.Count = 1 Or i = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
Rem 2
Workbooks.Open Filename:=Pth & wnm
'2a) Gets the column indicies of the columns wanted from the data worksheet
With ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant
vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , x , 3 , 4 , 5 , 11 , x , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let Cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
'2b) Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
Let arrOut__() = Application.Index(a(), Application.Transpose(Rws()), Cls_v()) ' Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
'2c) arrOut__() is not quite the final array we want. Its condensed missing out a couple of empty columns, so in code section '2b) we pick out the sections we want and put them in the appropriate place.
With .Range("B2") ' UsedRange.Offset(1)
'.ClearContents
.Resize(UBound(Rws()), 1) = Application.Index(arrOut__(), Evaluate("row(1:" & UBound(Rws()) & ")"), 1) ' column B in output
.Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), (Evaluate("row(1:" & UBound(Rws()) & ")")), Application.Transpose(Evaluate("row(2:" & UBound(arrOut__(), 2) & ")"))) ' column D to G
.Offset(, 7).Cells(1).Resize(UBound(Rws()), UBound(arrOut__(), 2) - 5).Value = Application.Index(arrOut__(), Evaluate("row(1:" & UBound(Rws()) & ")"), Application.Transpose(Evaluate("row(6:" & UBound(arrOut__(), 2) & ")"))) ' column I to O
.Offset(, 6).Cells(1).Resize(UBound(Rws())) = Application.Transpose(asum) ' sums column H
End With
End With
'.Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
End Sub




_._______________________________

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

[DocAElstein]

In support of this post


Source Workbook

_____ Workbook: Transfer data_marasAlan_2.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHA I
1NumberUnique IDNameTitlePlatformFilterSalaryAdd1Add2Add3Add4Add 5Add6Add7Add8Add9Add10Add11Add12copy1copy2copy3cop y4copy5copy6copy7

21123RamManagerJavaFilter2£400355123222

9126SomOperatorCFilter2£1501,013

102354SaiOperatorC++Filter2£150232241,126

172563ViduManagerJavaFilter2£400812147

183239JackLeadSQLFilter2£300454484149

194222AndyOperatorJavaFilter2£1504148151

242333FranOperatorSQLFilter2£15011161

2533658LaluLeadCFilter2£3006666112163

30

31
Worksheet: Sheet1

[DocAElstein]

In support of this post




Designation workbook before

_____ Workbook: Workbook2_2.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQ
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7

2
Worksheet: sheet1

Destination workbook after running macro Sub Transfer_marasAlan_2()

_____ Workbook: Workbook2_2.xlsx ( Using Excel 2007 32 bit )
Row\ColBCDEFGHIJKLMNOP
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7

2123RamManagerJava£40058123222

326SomOperatorC£15001,013

4354SaiOperatorC++£15025241,126

5563ViduManagerJava£4000812147

6239JackLeadSQL£300454484149

7222AndyOperatorJava£15004148151

8333FranOperatorSQL£1502161

93658LaluLeadC£30024112163

10
Worksheet: sheet1

[DocAElstein]

macro for last two posts


Option Explicit
Sub Transfer_marasAlan_2() '
Dim a(), Cls(), Cls_v() As String, Rws(), aSum(), arrOut__()
Dim Rng As Range, Rng_v As Range, Cel As Range, WbDest As Workbook
Dim i As Integer, ii As Integer
Dim Pth As String
Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const Pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const wnm = "Workbook2_2.xlsx" 'your workbook name
' Application.ScreenUpdating = False
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = .Range("a1:ag" & 25 & "") ' Hardcoded for demonstration purposes .UsedRange.Rows.Count)
Let a() = Rng.Value ' main complete data range
Let Cls() = Rng.Rows(1).Value ' header row array
ReDim Rws(1 To UBound(a)) ' This will be much too big initially - its the full all row size, but we will only want a reduced filtered number of rows - later #### this will be corrected
End With
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' this gets just the range we see, so will be likely a range of lots of areas
If Rng_v.Count > 1 Then
Rem 2 building a single column array for the summed colums
ReDim aSum(1 To Rng_v.Count) ' this is "one row too big" **
For Each Cel In Rng_v
If Cel.Row > 1 And Cel.Value <> "" Then
Let i = i + 1
Let aSum(i) = Evaluate("sum('[Transfer data_marasAlan_2.xlsm]Sheet1'!o" & Cel.Row & ": '[Transfer data_marasAlan_2.xlsm]Sheet1'!z" & Cel.Row & ")")
Let Rws(i) = Cel.Row
End If
Next
If i > 0 Then
ReDim Preserve aSum(1 To i) ' ** this sets the correct size
ReDim Preserve Rws(1 To i) ' #### this sets just enought row size for our final output array
Let aSum() = Application.Transpose(aSum()) ' we need a "virtical" "column" array
Let Rws() = Application.Transpose(Rws()) ' we need a virtical array in the second argumant of the Typical arrOut()=AppIndex(arrIn(), Rws(), Clms()) code line
End If
Else ' case only header range visible
End If
If Rng_v.Count = 1 Or i = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Set WbDest = Workbooks(wnm) ' will error if workbook is not yet open
If Err.Number > 0 Then Workbooks.Open Filename:=Pth & wnm ' we test to see if we have an error and if we do themn we kknow to open the workbook
On Error GoTo 0
Set WbDest = ActiveWorkbook
'2a) Gets the column indicies of the columns wanted from the data worksheet
With WbDest ' ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant ' just for demo purposes
Let vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , error , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , x, , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let Cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
'2b) Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
Let arrOut__() = Application.Index(a(), Rws(), Cls_v())
'2c) arrOut__() is not quite the final array we want. Its condensed missing out a couple of empty columns, so in code section '2c) we pick out the sections we want and put them in the appropriate place. In addition we paste in the sum columns that we got in section Rem 2
With Range("B2") ' .UsedRange.Offset(1)
.Resize(UBound(Rws), 1) = arrOut__() ' arrOut__() is 8 columns, but this linw will just put the first column in
Let Rws() = Evaluate("row(1:" & UBound(arrOut__()) & ")") ' for convenience again we are using the variable Rws() for sequential rows for our arrOut__() as we want all rows in the order that they are there
.Offset(, 2).Cells(1).Resize(UBound(arrOut__()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5)) ' columns D to G
.Offset(, 8).Cells(1).Resize(UBound(Rws()), UBound(arrOut__(), 2) - 5).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12)) ' columns J to P
.Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum() ' put the totals column in I
End With
End With
' .Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
End Sub






_._______________________________

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

[DocAElstein]

In support of this post

Source Workbook

_____ Workbook: Transfer data_marasAlan_3.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHA I
1NumberUnique IDNameTitlePlatformFilterSalaryAdd1Add2Add3Add4Add 5Add6Add7Add8Add9Add10Add11Add12copy1copy2copy3cop y4copy5copy6copy7Totalgrandtotal

433658LaluLeadCFilter2£3006666112
4
£1,200

92563ViduManagerJavaFilter2£400812
20
£8,000

102563ViduManagerJavaFilter2£425812
20
£8,500

122563ViduManagerJavaFilter2£400813
21
£8,400

162354SaiOperatorC++Filter2£15023224
24
£3,600

172333FranOperatorSQLFilter2£15011

£0

183239JackLeadSQLFilter2£566454484
20
£11,320

193239JackLeadSQLFilter2£3004644484
24
£7,200

234222AndyOperatorJavaFilter2£1504148
26
£3,900

241123RamManagerJavaFilter2£400355123
15

36126SomOperatorCFilter2£150

Worksheet: Sheet1

[DocAElstein]

In support of this post






Before destination

_____ Workbook: Workbook2_3.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRST
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7

2
Worksheet: Sheet1

After Destination

_____ Workbook: Workbook2_3.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRS
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7

23658LaluLeadC£300244112

3563ViduManagerJava£425020812

4354SaiOperatorC++£150252424

5333FranOperatorSQL£1502

6239JackLeadSQL£56645204484

7222AndyOperatorJava£1500264148

8123RamManagerJava£4005815123

926SomOperatorC£1500

10
Worksheet: Sheet1

[DocAElstein]

macro for last two posts


Option Explicit
Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624
Dim a(), cls_v() As String, Rws(), aSum(), arrOut__(), JagdDikIt()
Dim Rng As Range, Rng_v As Range, cel As Range
Dim Wrbk As Workbook, Rw As Long
Dim Pth As String
Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const Wnm = "Workbook2_3.xlsx" 'your workbook name
' Application.ScreenUpdating = False
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = .Range("a1:ai" & 36 & "") ' main data range hard coded to 36 for testing and demonstration .UsedRange.Rows.Count)
Let a() = Rng.Value ' all data values in the source. This will end up in the tyopical arrOut()=AppIndex( a(), Rws(), Clms() )
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' this gives us the range we see , (it is likely as a collection of areas) in the ID column
If Rng_v.Count > 1 Then
Rem 2 Make the sums column array, aSum() , and while we are looping we will collect the seen row indicies, Rws()
' ' ddddddddddddddddddddddd Dictionaray bit ------
' Dictionaray - The only reason to use this is that its a convenient way to get a unique list thing, or a unique set of things.
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary") ' https://excelmacromastery.com/vba-dictionary/
'Dim d As Scripting.Dictionary: Set d = New Scripting.Dictionary
Dim aTp() As Variant: ReDim aTp(1 To 3) ' This is a temporary array used to fill the dictionary Items it must be dynamic and variant type - see note +++ below
For Each cel In Rng_v ' we effectivelly are going down all the seen rows
If cel.Row > 1 And cel.Value <> "" Then
Let Rw = cel.Row
If Not Dik.exists(a(Rw, 2)) Then ' -Case we don't yet have any dictionaray item with this ID key
Let aTp(1) = Rw ' row number
Let aTp(2) = a(Rw, 35) ' grangtotal for this row
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' Our column Sums
Dik.Add Key:=a(Rw, 2), Item:=aTp() ' The key becomes the ID , The Item is a three element array of the row number the columns sum for this row the gradtotal for this row shothand way to do this line is d(a(r, 2)) = atp
Else ' ' -Case we already have a dictionary item with this key
Let aTp() = Dik.Item(a(Rw, 2)) ' we are returning an item that is an array, so the recieving array variable must be dynamic. the returned element type3s are Variant +++
If a(Rw, 35) > aTp(2) Then ' If the grand total for this row and ID is greater than a previous, then ....
Let aTp(1) = Rw ' we are replacing ..
Let aTp(2) = a(Rw, 35) ' .. the item with the relavent ..
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' .. info from this row
Dik(a(Rw, 2)) = aTp() ' shorthand version for Dik.Add Key:=a(Rw, 2), Item:=aTp()
End If
End If ' end of making or replacing a dictiuonary item
Else
End If
Next
' at this point we have a dictionary that has one Item for each ID
' in this last Dik bit we use the first and third part of the 3 element items in a pseudo arrOut()=AppIndex( arrUnjaggedJaged(), Rws() , Clms() ) ' https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
If Dik.Count Then
'Let JagdDikIt() = Application.Transpose(Dik.items()) ' we can treat an unjagged jagged array that is a 1 D array of 1 D arrays as if it was a 2 D array ... https://eileenslounge.com/viewtopic.php?p=266691#p266691
Let JagdDikIt() = Dik.items()
'Let Rws() = Application.Index(JagdDikIt(), 1, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let Rws() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 1) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
'Let aSum() = Application.Index(JagdDikIt(), 3, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let aSum() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 3) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
' ' ddddddddddddddddddddddddd -----------------------------
Else
End If
Else ' case only a header row to be seen
End If
End With
If Rng_v.Count = 1 Or Dik.Count = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Set Wrbk = Workbooks(Wnm)
If Wrbk Is Nothing Then
Workbooks.Open Filename:=Pth & Wnm
Else
Workbooks(Wnm).Activate
End If
On Error GoTo 0
With ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant ' just for demo purposes
Let vTemp = .UsedRange.Rows(1)
' { empty , Unique ID , Gap ,Name , Title , Platform , Salary , Gap, Total , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Formula7 , Formula8 , Formula9 }
Let vTemp = Rng.Rows(1)
' { Number , ID , Name , Title , Platform , Filter , , , , ,Salary , , , ,Add1 , Add2 , Add3 , Add4 , Add5 , Add6 , Add7 , Add8 , Add9 , Add10 , Add11 , Add12 , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Total , grandtotal }
Let vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 28 , error ,error ,error ,error ,error ,error ,error ,error ,error , }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , x ,x ,x ,x ,x ,x ,x ,x ,x , }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , 3 , 4 , 5 , 11 , 34, 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
With .Range("B2") ' .UsedRange.Offset(1)
' .Resize(, 15).ClearContents
Let arrOut__() = Application.Index(a(), Rws(), cls_v())
.Resize(UBound(Rws()), 1) = arrOut__()
Let Rws() = Evaluate("row(1:" & UBound(Rws()) & ")") ' Using the variable Rws() for a sequential indicie list 1; 2; 3 ... etc for all rows in the arrOut__()
.Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5)) ' columns D - G
.Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum() ' columm I
.Offset(, 8).Cells(1).Resize(UBound(Rws()), 7).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12)) ' Column J to P
End With
End With
' .Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
' Set cel = Nothing
Set Dik = Nothing
End Sub

[DocAElstein]

ycb<ybc,bc,ybcybyb

[DocAElstein]

In support of this posting
https://eileenslounge.com/viewtopic.php?p=280747#p280747

befores
_____ Workbook: Workbook2_2b.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAA
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7From SHEET2SalaryTotalcopy1copy2copy3copy4copy5copy6cop y7

2

3

4

5

6

7

8

9

10

11
Worksheet: Destination

[DocAElstein]

In support of this posting
https://eileenslounge.com/viewtopic.php?p=280747#p280747


_____ Workbook: Transfer data_marasAlan_2b.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAG
1NumberUnique IDNameTitlePlatformFilterSalaryAdd1Add2Add3Add4Add 5Add6Add7Add8Add9Add10Add11Add12copy1copy2copy3cop y4copy5copy6copy7

21123RamManagerJavaFilter2£400355123222

9126SomOperatorCFilter2£1501,013

102354SaiOperatorC++Filter2£150232241,126

172563ViduManagerJavaFilter2£400812147

183239JackLeadSQLFilter2£300454484149

194222AndyOperatorJavaFilter2£1504148151

242333FranOperatorSQLFilter2£15011161

2533658LaluLeadCFilter2£3006666112163
Worksheet: Sheet1

[DocAElstein]

In support of this posting
https://eileenslounge.com/viewtopic.php?p=280747#p280747

The after


_____ Workbook: Workbook2_2b.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAA
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7From SHEET2SalaryTotalcopy1copy2copy3copy4copy5copy6cop y7

2123RamManagerJava£40058123222

326SomOperatorC£15001,013

4354SaiOperatorC++£15025241,126

5563ViduManagerJava£4000812147

6239JackLeadSQL£300454484149

7222AndyOperatorJava£15004148151

8333FranOperatorSQL£1502161

93658LaluLeadC£30024112163

10

11
Worksheet: Destination

[DocAElstein]

Macro for last 3 posts


Option Explicit
Sub Transfer_Sht1After() ' https://eileenslounge.com/viewtopic.php?p=280747#p280747
Rem 1 Source Worksheets info
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Dim Lr1 As Long: Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row
'1b) Any column in the visible data is taken in the next code line, the main reason being as we need to get the row indicie info
Dim Rng_v As Range: Set Rng_v = Ws1.Range("B1:B" & Lr1 & "").SpecialCells(xlCellTypeVisible) ' this gets just the range we see, so will be likely a range of lots of areas
If Rng_v.Count = 1 Then ' case only header range visible
MsgBox Prompt:="No rows to transfer.": Exit Sub
Else ' there are visible rows to transfer
Rem 2 building a single column array for the summed colums, and the wanted visible row indicies from the main range
Dim aSum() As Variant: ReDim aSum(1 To Rng_v.Count - 1, 1 To 1) ' This will be a column array when applied to a worksheet
Dim Rws() As Long: ReDim Rws(1 To Rng_v.Count - 1, 1 To 1) ' we need a "virtical" array containing the "seen" row indicies
Dim Cel As Range
For Each Cel In Rng_v ' These are the cells in the multi Area range of visible cells
If Cel.Row > 1 And Cel.Value <> "" Then
Dim I As Long
Let I = I + 1
Let aSum(I, 1) = Evaluate("=Sum('[" & ThisWorkbook.Name & "]Sheet1'!O" & Cel.Row & ":'[" & ThisWorkbook.Name & "]Sheet1'!Z" & Cel.Row & ")")
Let Rws(I, 1) = Cel.Row ' This puts the visible rows indicie in our array indicationg the rows we need from the worksheet
Else
End If
Next Cel
End If
' Destination workbook and worksheet
Dim Pth As String: Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const Pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const Wnm = "Workbook2_2b.xlsx" 'your destination workbook2 name
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Dim WbDest As Workbook
Set WbDest = Workbooks(Wnm) ' will error if workbook is not yet open
If Err.Number > 0 Then
Workbooks.Open Filename:=Pth & Wnm ' we test to see if we have an error and if we do themn we kknow to open the workbook On Error GoTo 0
Set WbDest = ActiveWorkbook
Else
End If
''2a) Column indicies of the columns wanted from the data worksheet
Dim Clms() As Variant: Let Clms() = Array(2, 34, 3, 4, 5, 11, 34, 34, 27, 28, 29, 30, 31, 32, 33)
'2b) Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
Let WbDest.Worksheets.Item(1).Range("B2").Resize(UBound(Rws(), 1), 15).Value2 = Application.Index(Ws1.Cells, Rws(), Clms())
'2c)(ii) Sums column
Let WbDest.Worksheets.Item(1).Range("B2").Resize(UBound(Rws(), 1), 1).Offset(0, 7).Value2 = aSum()
End Sub

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

ahdlaKHDLakhdalkhd

[DocAElstein]

Links hcDHADLHADHAD

[DocAElstein]

AKHDalkhd

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

ADLAdlAHDLAhdlakHDLadh

[DocAElstein]

I forgot about this Blog tip thread for a while.

The reason for that was that I answered a few threads, where someone asked for help because something was not doing what they wanted, and the reason for that was that they were trying to get a UDF to change the value of another cell, or something very similar.
My solution seemed to work. Sometimes the OP seemed happy. But more often than not, I got a lot of hate from some senior member, “expert Guru”, Moderator, or similar, insisting that a UDF cannot change the value of any cell other than the one it is in.



It’s about 2 years later now. Maybe it’s safe to post something about it again.
In the meantime, I still don’t have any newer versions of Office/ Excel, so maybe I will post a very simple example, and ask people to test it for me on newer versions. I won’t present it as "a UDF that can change the value of another cell, other than the one the UDF is in".

See how it goes.


I made a much simplified sample file, as enclosed



Feedback so far

http://www.eileenslounge.com/viewtopic.php?p=280303&sid=fc2daaad9994cb916e0ff601b8ff4995#p280303





Any Other Threads doing something similar
https://stackoverflow.com/questions/54753141/excel-vba-user-defined-function-that-counts-cells-with-conditional-formatting
https://www.mrexcel.com/board/threads/using-displayformat-in-a-udf.1154593/

[DocAElstein]

Links relavent to the last 9 postsLKADHladhlAHAlhdaLDH

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Another example, possibly, indirectly
http://www.eileenslounge.com/viewtopic.php?f=30&t=38798
This is a different problem. Indeed we want the UDF to give a result in the cell in which it is, as more typically using a UDF.
But a couple of things reminded me of discussions here…
_1) Something is not working from inside a UDF, something that otherwise works.
_2) A sudden abrupt termination, without an error, in the step ( F8 ) debug mode code execution.
_3) The thing not working is generally “wired” to interact with things in cells in a spreadsheet

So I investigated.

The first problem I had was that the thing ( DisplayFormat ) not working at all in my earlier Office/Excel versions.
But I got to check this later in 2013, https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=18404&viewfull=1#post18404 , and confirmed the issue. DisplayFormat is working to return a value in a normal sub routine and a function, and the snag is just it working in a spreadsheet ( applying the function as available in a spreadsheet formula )

I actually won’t close to the opposite of what I was doing here.
Lets not talk about what I was doing. ( That seems controversial anyway )
Lets approach it a bit laterally thinking

What is/ was the goings on:

We got two things:

' First thing
Function WotsThereWhere(ByVal Rng As Range) As String
Evaluate "='" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'!UDFchangeotherCells.YouNameIt(" & Rng.Address & ", """ & ActiveSheet.Name & """)" ' Evaluate "=YouNameIt(" & Rng.Address & ", """ & ActiveSheet.Name & """)" ' : Debug.Print "=YouNameIt(" & Rng.Address & ", """ & ActiveSheet.Name & """)" ' gives YouNameIt($A$1, "Sheet1")
' Evaluate "YouNameIt($A$1, ""Sheet1"")" ' Shortened version relying on default
End Function


' Second thing
Sub YouNameIt(ByVal Rng As Range, ByVal Sht As String)
Stop ' It wont
Let Rng.Offset(0, 2).Value = ""
Let Rng.Offset(0, 2).Value = "You wrote " & Rng.Value & " in cell " & Rng.Address(0, 0) & ", in worksheet " & Sht
End Sub
The first thing, Function ( used as a spreadsheet UDF) , WotsThereWhere , is on the signature line, normal looking, ( and in this case it takes an argument, a range object. )
( The only reason in this case why it is As String declared , is that it is not wanted to return anything as I was using it, at least nothing to us visible. If , for example, it was alternatively As Long declared, then I would see a zero )
The coding in that function is just one line. It Evaluates the string name of a sub routine, that sub routine is our second thing

That single code line somehow sets off the second thing , a sub routine which does what did not work directly inside the function.

That’s it

What do we conclude relevant to the current problem (https://eileenslounge.com/viewtopic.php?p=300075&sid=4fd3626428d1c8bafd17c5911ac23fcf#p300075) It seems like the thing to try is to get the second thing to
_(i) do something with DisplayFormat, and
_(ii) put the result of that ) do something with DisplayFormat in the cell where we have the UDF using the first thing function


So here we go!

Lets duplicate the first and second thing, put them in a new code module, , and give things different names more appropriate to what we are talking about, the current issues: requirements and problems
So in normal code module I name , DisplayFormatUDF, I have

Option Explicit
' First thing
Function DoSubDoDisplayFormat(ByVal Rng As Range) As String
Evaluate "='" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'!DisplayFormatUDF.DoDisplayFormat(" & Rng.Address & ", """ & ActiveSheet.Name & """)" ' Evaluate "=YouNameIt(" & Rng.Address & ", """ & ActiveSheet.Name & """)" ' : Debug.Print "=YouNameIt(" & Rng.Address & ", """ & ActiveSheet.Name & """)" ' gives YouNameIt($A$1, "Sheet1")
' Evaluate "DoDisplayFormat ($A$1, ""Sheet1"")" ' Shortened version relying on default
End Function


' Second thing
Sub DoDisplayFormat(ByVal Rng As Range, ByVal Sht As String)
Stop ' It wont
Let Rng.Offset(0, 2).Value = ""
Let Rng.Offset(0, 2).Value = "You wrote " & Rng.Value & " in cell " & Rng.Address(0, 0) & ", in worksheet " & Sht
End Sub

I remove Adeel’s formula in his cell D17, ( {=sum_color(D6:G15;C17)} ) and I replace it with =DoSubDoDisplayFormat(C17)
It seems to then give similar results to what I expect. All is well: https://i.postimg.cc/bG3yh6J6/You-Wrote11in-Cell-C17.jpg (https://postimg.cc/bG3yh6J6)


So lets start in the next post with the “AdeelSolution1”






Share ‘DisplayFormatInUDF.xlsm’ https://app.box.com/s/e4307kqrwx6zqk9uwswlpfziz6air9gy

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

ADHLhdlhd

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

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

1
TEST-1









2Name of the Student :
Rizwana


3Reg. No. :
256


4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS






2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks


3
01Rukhsar banu
256
X
2


4
02Abdulkhadar
123
X
3


5
03Rizwana
256
X
4


6
04Rizwana
256
X
4


7
05Rizwana
256
X
4
Worksheet: Result








15283

[DocAElstein]

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

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

1
TEST-1









2Name of the Student :
Rizwana


3Reg. No. :
256


4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS






2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks


3
01Rukhsar banu
256
X
2


4
02Abdulkhadar
123
X
3


5
03Rizwana
256
X
4


6
04Rizwana
256
X
4


7
05Rizwana
256
X
4
Worksheet: Result

[DocAElstein]

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

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

1
TEST-1









2Name of the Student :
Rizwana


3Reg. No. :
256


4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS






2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks


3
01Rukhsar banu
256
X
2


4
02Abdulkhadar
123
X
3


5
03Rizwana
256
X
4


6
04Rizwana
256
X
4


7
05Rizwana
256
X
4
Worksheet: Result

[DocAElstein]

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

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

1
TEST-1









2Name of the Student :
Rizwana


3Reg. No. :
256


4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS






2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks


3
01Rukhsar banu
256
X
2


4
02Abdulkhadar
123
X
3


5
03Rizwana
256
X
4


6
04Rizwana
256
X
4


7
05Rizwana
256
X
4
Worksheet: Result

[DocAElstein]

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

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

1
TEST-1









2Name of the Student :
Rizwana


3Reg. No. :
256


4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS






2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks


3
01Rukhsar banu
256
X
2


4
02Abdulkhadar
123
X
3


5
03Rizwana
256
X
4


6
04Rizwana
256
X
4


7
05Rizwana
256
X
4
Worksheet: Result

[DocAElstein]

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

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

1
TEST-1









2Name of the Student :
Rizwana


3Reg. No. :
256


4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS






2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks


3
01Rukhsar banu
256
X
2


4
02Abdulkhadar
123
X
3


5
03Rizwana
256
X
4


6
04Rizwana
256
X
4


7
05Rizwana
256
X
4
Worksheet: Result

[DocAElstein]

macro for last two posts


Option Explicit
Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624
Dim a(), cls_v() As String, Rws(), aSum(), arrOut__(), JagdDikIt()
Dim Rng As Range, Rng_v As Range, cel As Range
Dim Wrbk As Workbook, Rw As Long
Dim Pth As String
Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const Wnm = "Workbook2_3.xlsx" 'your workbook name
' Application.ScreenUpdating = False
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = .Range("a1:ai" & 36 & "") ' main data range hard coded to 36 for testing and demonstration .UsedRange.Rows.Count)
Let a() = Rng.Value ' all data values in the source. This will end up in the tyopical arrOut()=AppIndex( a(), Rws(), Clms() )
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' this gives us the range we see , (it is likely as a collection of areas) in the ID column
If Rng_v.Count > 1 Then
Rem 2 Make the sums column array, aSum() , and while we are looping we will collect the seen row indicies, Rws()
' ' ddddddddddddddddddddddd Dictionaray bit ------
' Dictionaray - The only reason to use this is that its a convenient way to get a unique list thing, or a unique set of things.
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary") ' https://excelmacromastery.com/vba-dictionary/
'Dim d As Scripting.Dictionary: Set d = New Scripting.Dictionary
Dim aTp() As Variant: ReDim aTp(1 To 3) ' This is a temporary array used to fill the dictionary Items it must be dynamic and variant type - see note +++ below
For Each cel In Rng_v ' we effectivelly are going down all the seen rows
If cel.Row > 1 And cel.Value <> "" Then
Let Rw = cel.Row
If Not Dik.exists(a(Rw, 2)) Then ' -Case we don't yet have any dictionaray item with this ID key
Let aTp(1) = Rw ' row number
Let aTp(2) = a(Rw, 35) ' grangtotal for this row
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' Our column Sums
Dik.Add Key:=a(Rw, 2), Item:=aTp() ' The key becomes the ID , The Item is a three element array of the row number the columns sum for this row the gradtotal for this row shothand way to do this line is d(a(r, 2)) = atp
Else ' ' -Case we already have a dictionary item with this key
Let aTp() = Dik.Item(a(Rw, 2)) ' we are returning an item that is an array, so the recieving array variable must be dynamic. the returned element type3s are Variant +++
If a(Rw, 35) > aTp(2) Then ' If the grand total for this row and ID is greater than a previous, then ....
Let aTp(1) = Rw ' we are replacing ..
Let aTp(2) = a(Rw, 35) ' .. the item with the relavent ..
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' .. info from this row
Dik(a(Rw, 2)) = aTp() ' shorthand version for Dik.Add Key:=a(Rw, 2), Item:=aTp()
End If
End If ' end of making or replacing a dictiuonary item
Else
End If
Next
' at this point we have a dictionary that has one Item for each ID
' in this last Dik bit we use the first and third part of the 3 element items in a pseudo arrOut()=AppIndex( arrUnjaggedJaged(), Rws() , Clms() ) ' https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
If Dik.Count Then
'Let JagdDikIt() = Application.Transpose(Dik.items()) ' we can treat an unjagged jagged array that is a 1 D array of 1 D arrays as if it was a 2 D array ... https://eileenslounge.com/viewtopic.php?p=266691#p266691
Let JagdDikIt() = Dik.items()
'Let Rws() = Application.Index(JagdDikIt(), 1, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let Rws() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 1) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
'Let aSum() = Application.Index(JagdDikIt(), 3, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let aSum() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 3) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
' ' ddddddddddddddddddddddddd -----------------------------
Else
End If
Else ' case only a header row to be seen
End If
End With
If Rng_v.Count = 1 Or Dik.Count = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Set Wrbk = Workbooks(Wnm)
If Wrbk Is Nothing Then
Workbooks.Open Filename:=Pth & Wnm
Else
Workbooks(Wnm).Activate
End If
On Error GoTo 0
With ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant ' just for demo purposes
Let vTemp = .UsedRange.Rows(1)
' { empty , Unique ID , Gap ,Name , Title , Platform , Salary , Gap, Total , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Formula7 , Formula8 , Formula9 }
Let vTemp = Rng.Rows(1)
' { Number , ID , Name , Title , Platform , Filter , , , , ,Salary , , , ,Add1 , Add2 , Add3 , Add4 , Add5 , Add6 , Add7 , Add8 , Add9 , Add10 , Add11 , Add12 , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Total , grandtotal }
Let vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 28 , error ,error ,error ,error ,error ,error ,error ,error ,error , }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , x ,x ,x ,x ,x ,x ,x ,x ,x , }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , 3 , 4 , 5 , 11 , 34, 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
With .Range("B2") ' .UsedRange.Offset(1)
' .Resize(, 15).ClearContents
Let arrOut__() = Application.Index(a(), Rws(), cls_v())
.Resize(UBound(Rws()), 1) = arrOut__()
Let Rws() = Evaluate("row(1:" & UBound(Rws()) & ")") ' Using the variable Rws() for a sequential indicie list 1; 2; 3 ... etc for all rows in the arrOut__()
.Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5)) ' columns D - G
.Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum() ' columm I
.Offset(, 8).Cells(1).Resize(UBound(Rws()), 7).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12)) ' Column J to P
End With
End With
' .Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
' Set cel = Nothing
Set Dik = Nothing
End Sub

[DocAElstein]

Links relavent to the last 9 posts


' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5





_.________________________________________________ _________________________________________________





Sub Transfer_marasAlan_2() '


Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273


Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz
















_.___________________________________________


Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

[DocAElstein]

macro for last two posts


Option Explicit
Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624
Dim a(), cls_v() As String, Rws(), aSum(), arrOut__(), JagdDikIt()
Dim Rng As Range, Rng_v As Range, cel As Range
Dim Wrbk As Workbook, Rw As Long
Dim Pth As String
Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const Wnm = "Workbook2_3.xlsx" 'your workbook name
' Application.ScreenUpdating = False
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = .Range("a1:ai" & 36 & "") ' main data range hard coded to 36 for testing and demonstration .UsedRange.Rows.Count)
Let a() = Rng.Value ' all data values in the source. This will end up in the tyopical arrOut()=AppIndex( a(), Rws(), Clms() )
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' this gives us the range we see , (it is likely as a collection of areas) in the ID column
If Rng_v.Count > 1 Then
Rem 2 Make the sums column array, aSum() , and while we are looping we will collect the seen row indicies, Rws()
' ' ddddddddddddddddddddddd Dictionaray bit ------
' Dictionaray - The only reason to use this is that its a convenient way to get a unique list thing, or a unique set of things.
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary") ' https://excelmacromastery.com/vba-dictionary/
'Dim d As Scripting.Dictionary: Set d = New Scripting.Dictionary
Dim aTp() As Variant: ReDim aTp(1 To 3) ' This is a temporary array used to fill the dictionary Items it must be dynamic and variant type - see note +++ below
For Each cel In Rng_v ' we effectivelly are going down all the seen rows
If cel.Row > 1 And cel.Value <> "" Then
Let Rw = cel.Row
If Not Dik.exists(a(Rw, 2)) Then ' -Case we don't yet have any dictionaray item with this ID key
Let aTp(1) = Rw ' row number
Let aTp(2) = a(Rw, 35) ' grangtotal for this row
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' Our column Sums
Dik.Add Key:=a(Rw, 2), Item:=aTp() ' The key becomes the ID , The Item is a three element array of the row number the columns sum for this row the gradtotal for this row shothand way to do this line is d(a(r, 2)) = atp
Else ' ' -Case we already have a dictionary item with this key
Let aTp() = Dik.Item(a(Rw, 2)) ' we are returning an item that is an array, so the recieving array variable must be dynamic. the returned element type3s are Variant +++
If a(Rw, 35) > aTp(2) Then ' If the grand total for this row and ID is greater than a previous, then ....
Let aTp(1) = Rw ' we are replacing ..
Let aTp(2) = a(Rw, 35) ' .. the item with the relavent ..
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' .. info from this row
Dik(a(Rw, 2)) = aTp() ' shorthand version for Dik.Add Key:=a(Rw, 2), Item:=aTp()
End If
End If ' end of making or replacing a dictiuonary item
Else
End If
Next
' at this point we have a dictionary that has one Item for each ID
' in this last Dik bit we use the first and third part of the 3 element items in a pseudo arrOut()=AppIndex( arrUnjaggedJaged(), Rws() , Clms() ) ' https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
If Dik.Count Then
'Let JagdDikIt() = Application.Transpose(Dik.items()) ' we can treat an unjagged jagged array that is a 1 D array of 1 D arrays as if it was a 2 D array ... https://eileenslounge.com/viewtopic.php?p=266691#p266691
Let JagdDikIt() = Dik.items()
'Let Rws() = Application.Index(JagdDikIt(), 1, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let Rws() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 1) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
'Let aSum() = Application.Index(JagdDikIt(), 3, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let aSum() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 3) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
' ' ddddddddddddddddddddddddd -----------------------------
Else
End If
Else ' case only a header row to be seen
End If
End With
If Rng_v.Count = 1 Or Dik.Count = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Set Wrbk = Workbooks(Wnm)
If Wrbk Is Nothing Then
Workbooks.Open Filename:=Pth & Wnm
Else
Workbooks(Wnm).Activate
End If
On Error GoTo 0
With ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant ' just for demo purposes
Let vTemp = .UsedRange.Rows(1)
' { empty , Unique ID , Gap ,Name , Title , Platform , Salary , Gap, Total , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Formula7 , Formula8 , Formula9 }
Let vTemp = Rng.Rows(1)
' { Number , ID , Name , Title , Platform , Filter , , , , ,Salary , , , ,Add1 , Add2 , Add3 , Add4 , Add5 , Add6 , Add7 , Add8 , Add9 , Add10 , Add11 , Add12 , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Total , grandtotal }
Let vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 28 , error ,error ,error ,error ,error ,error ,error ,error ,error , }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , x ,x ,x ,x ,x ,x ,x ,x ,x , }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , 3 , 4 , 5 , 11 , 34, 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
With .Range("B2") ' .UsedRange.Offset(1)
' .Resize(, 15).ClearContents
Let arrOut__() = Application.Index(a(), Rws(), cls_v())
.Resize(UBound(Rws()), 1) = arrOut__()
Let Rws() = Evaluate("row(1:" & UBound(Rws()) & ")") ' Using the variable Rws() for a sequential indicie list 1; 2; 3 ... etc for all rows in the arrOut__()
.Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5)) ' columns D - G
.Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum() ' columm I
.Offset(, 8).Cells(1).Resize(UBound(Rws()), 7).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12)) ' Column J to P
End With
End With
' .Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
' Set cel = Nothing
Set Dik = Nothing
End Sub

[DocAElstein]

macro for last two posts


Option Explicit
Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624
Dim a(), cls_v() As String, Rws(), aSum(), arrOut__(), JagdDikIt()
Dim Rng As Range, Rng_v As Range, cel As Range
Dim Wrbk As Workbook, Rw As Long
Dim Pth As String
Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const Wnm = "Workbook2_3.xlsx" 'your workbook name
' Application.ScreenUpdating = False
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = .Range("a1:ai" & 36 & "") ' main data range hard coded to 36 for testing and demonstration .UsedRange.Rows.Count)
Let a() = Rng.Value ' all data values in the source. This will end up in the tyopical arrOut()=AppIndex( a(), Rws(), Clms() )
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' this gives us the range we see , (it is likely as a collection of areas) in the ID column
If Rng_v.Count > 1 Then
Rem 2 Make the sums column array, aSum() , and while we are looping we will collect the seen row indicies, Rws()
' ' ddddddddddddddddddddddd Dictionaray bit ------
' Dictionaray - The only reason to use this is that its a convenient way to get a unique list thing, or a unique set of things.
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary") ' https://excelmacromastery.com/vba-dictionary/
'Dim d As Scripting.Dictionary: Set d = New Scripting.Dictionary
Dim aTp() As Variant: ReDim aTp(1 To 3) ' This is a temporary array used to fill the dictionary Items it must be dynamic and variant type - see note +++ below
For Each cel In Rng_v ' we effectivelly are going down all the seen rows
If cel.Row > 1 And cel.Value <> "" Then
Let Rw = cel.Row
If Not Dik.exists(a(Rw, 2)) Then ' -Case we don't yet have any dictionaray item with this ID key
Let aTp(1) = Rw ' row number
Let aTp(2) = a(Rw, 35) ' grangtotal for this row
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' Our column Sums
Dik.Add Key:=a(Rw, 2), Item:=aTp() ' The key becomes the ID , The Item is a three element array of the row number the columns sum for this row the gradtotal for this row shothand way to do this line is d(a(r, 2)) = atp
Else ' ' -Case we already have a dictionary item with this key
Let aTp() = Dik.Item(a(Rw, 2)) ' we are returning an item that is an array, so the recieving array variable must be dynamic. the returned element type3s are Variant +++
If a(Rw, 35) > aTp(2) Then ' If the grand total for this row and ID is greater than a previous, then ....
Let aTp(1) = Rw ' we are replacing ..
Let aTp(2) = a(Rw, 35) ' .. the item with the relavent ..
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' .. info from this row
Dik(a(Rw, 2)) = aTp() ' shorthand version for Dik.Add Key:=a(Rw, 2), Item:=aTp()
End If
End If ' end of making or replacing a dictiuonary item
Else
End If
Next
' at this point we have a dictionary that has one Item for each ID
' in this last Dik bit we use the first and third part of the 3 element items in a pseudo arrOut()=AppIndex( arrUnjaggedJaged(), Rws() , Clms() ) ' https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
If Dik.Count Then
'Let JagdDikIt() = Application.Transpose(Dik.items()) ' we can treat an unjagged jagged array that is a 1 D array of 1 D arrays as if it was a 2 D array ... https://eileenslounge.com/viewtopic.php?p=266691#p266691
Let JagdDikIt() = Dik.items()
'Let Rws() = Application.Index(JagdDikIt(), 1, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let Rws() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 1) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
'Let aSum() = Application.Index(JagdDikIt(), 3, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let aSum() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 3) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
' ' ddddddddddddddddddddddddd -----------------------------
Else
End If
Else ' case only a header row to be seen
End If
End With
If Rng_v.Count = 1 Or Dik.Count = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Set Wrbk = Workbooks(Wnm)
If Wrbk Is Nothing Then
Workbooks.Open Filename:=Pth & Wnm
Else
Workbooks(Wnm).Activate
End If
On Error GoTo 0
With ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant ' just for demo purposes
Let vTemp = .UsedRange.Rows(1)
' { empty , Unique ID , Gap ,Name , Title , Platform , Salary , Gap, Total , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Formula7 , Formula8 , Formula9 }
Let vTemp = Rng.Rows(1)
' { Number , ID , Name , Title , Platform , Filter , , , , ,Salary , , , ,Add1 , Add2 , Add3 , Add4 , Add5 , Add6 , Add7 , Add8 , Add9 , Add10 , Add11 , Add12 , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Total , grandtotal }
Let vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 28 , error ,error ,error ,error ,error ,error ,error ,error ,error , }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , x ,x ,x ,x ,x ,x ,x ,x ,x , }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , 3 , 4 , 5 , 11 , 34, 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
With .Range("B2") ' .UsedRange.Offset(1)
' .Resize(, 15).ClearContents
Let arrOut__() = Application.Index(a(), Rws(), cls_v())
.Resize(UBound(Rws()), 1) = arrOut__()
Let Rws() = Evaluate("row(1:" & UBound(Rws()) & ")") ' Using the variable Rws() for a sequential indicie list 1; 2; 3 ... etc for all rows in the arrOut__()
.Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5)) ' columns D - G
.Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum() ' columm I
.Offset(, 8).Cells(1).Resize(UBound(Rws()), 7).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12)) ' Column J to P
End With
End With
' .Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
' Set cel = Nothing
Set Dik = Nothing
End Sub

[DocAElstein]

In suppot of this thread
https://excelfox.com/forum/showthread.php/2709-Order-multiple-texts-in-quot-row-cells-quot-in-columns?p=15292#post15292

Input data


_____ Workbook: VBA3.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F

1Find word1Abc2wer#3smar4chris


2AP1kAP1k, 6-9| AP1k, 10-13


3ForComeForCome, 13-19


4


5DoubleDouble, 14-16 | Double, 14-16| Double, 14-16Double, 14-16| Double, 14-16Double, 14-16| Double, 14-16
Worksheet: inputA


Wanted Output

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

1Output


21Abc


32wer#AP1k, 6-9


42wer#AP1k, 10-13


52wer#Double, 14-16


62wer#Double, 14-16


72wer#Double, 14-16


83smarForCome, 13-19


93smarDouble, 14-16


103smarDouble, 14-16


114chrisDouble, 14-16


124chrisDouble, 14-16
Worksheet: OutputB


Results after running macro in next post

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

1


21Abc


32wer#AP1k, 6-9


42wer# AP1k, 10-13


52wer#Double, 14-16


62wer# Double, 14-16


72wer# Double, 14-16


83smarForCome, 13-19


93smarDouble, 14-16


103smar Double, 14-16


114chrisDouble, 14-16


124chris Double, 14-16
Worksheet: Output

[DocAElstein]

Macro for last post


Option Explicit
Sub StartOffvbadumbarse()
Rem 1 Worksheets info
Dim WsIn As Worksheet, WsOut As Worksheet
Set WsIn = ThisWorkbook.Worksheets.Item(1): Set WsOut = ThisWorkbook.Worksheets.Item(2)
Dim arrIn() As Variant: Let arrIn() = WsIn.Range("B1:F5").Value2
Rem 2
'2b
Dim Clm As Long
For Clm = 1 To 5 Step 1
If arrIn(1, Clm) = "" Then
' Nothing to do for no header
Else
Dim Itms As String: Let Itms = arrIn(1, Clm)
Dim RwDta As Long
For RwDta = 2 To 5 Step 1
Dim strFndWd As String
If arrIn(RwDta, Clm) = "" Then
' no data
Else
If InStr(1, arrIn(RwDta, Clm), "|", vbBinaryCompare) > 0 Then ' we must have two or more datas seperatied by a |
Dim CelDts As Long
For CelDts = 0 To UBound(Split(arrIn(RwDta, Clm), "|", -1, vbBinaryCompare))
Let strFndWd = strFndWd & Split(arrIn(RwDta, Clm), "|", -1, vbBinaryCompare)(CelDts) & vbCr & vbLf
Next CelDts
Else ' case single data
Let strFndWd = strFndWd & arrIn(RwDta, Clm) & vbCr & vbLf ' effectively a single row is added for this data
End If
End If
Next RwDta
'2e we have been through the data, so time to see what we got and fill our two strings appropriately
Dim strOutA As String, strOutB As String
If strFndWd = "" Then ' case we had no data
Let strFndWd = strFndWd & vbCr & vbLf ' effectively adds an empty row
Let strOutA = strOutA & Itms & vbCr & vbLf ' a single row with header
Else ' we have data, so need do add some rows to strOutA ( strOutB effecively has all the rows determined by the number of vbCr & vbLf added
Dim RwCnt As Long: Let RwCnt = UBound(Split(strFndWd, vbCr & vbLf, -1, vbBinaryCompare)) + 1 - 1 ' The number of vbCr & vbLf gives us the number rows
For CelDts = 1 To RwCnt
Let strOutA = strOutA & Itms & vbCr & vbLf
Next CelDts
End If
End If
Let strOutB = strOutB & strFndWd
Let strFndWd = ""
Next Clm
' I can view my data in a message box or in the immediate window
MsgBox Prompt:=strOutA: Debug.Print strOutA
MsgBox Prompt:=strOutB: Debug.Print strOutB

Rem 3 outout
Dim arrOutA() As String: Let arrOutA() = Split(strOutA, vbCr & vbLf, -1, vbBinaryCompare) ' Excel has the convention of taking a 1D array as being "horizontal" for spreadsheet purposes, so will consider it as a row of data values if applied to a worksheet range
Dim arrOutB() As String: Let arrOutB() = Split(strOutB, vbCr & vbLf, -1, vbBinaryCompare)
' Let WsOut.Range("A2").Resize(UBound(arrOutA()), 1).Value = Application.Transpose(arrOutA())
Let WsOut.Range("A2").Resize(UBound(arrOutA()), 1).Value = Application.Index(arrOutA(), Evaluate("=row(1:" & UBound(arrOutA()) & ")/row(1:" & UBound(arrOutA()) & ")"), Evaluate("=row(1:" & UBound(arrOutA()) & ")"))
' Let WsOut.Range("B2").Resize(UBound(arrOutB()), 1).Value = Application.Transpose(arrOutB())
Let WsOut.Range("B2").Resize(UBound(arrOutB()), 1).Value = Application.Index(arrOutB(), Evaluate("=row(1:" & UBound(arrOutB()) & ")/row(1:" & UBound(arrOutB()) & ")"), Evaluate("=row(1:" & UBound(arrOutB()) & ")"))
End Sub

[DocAElstein]

for later use

[DocAElstein]

In support of this post
http://www.eileenslounge.com/viewtopic.php?p=281164#p281164


Sub On___Then____() ' http://www.eileenslounge.com/viewtopic.php?p=281164#p281164
' Going nowhere the first ____ evaluates to a number in range 0 or 2 , 3, 4 ..... 255 so I don't GoTo
On 0.2 GoTo NeverBeHere
On Err GoTo NeverBeHere
On TwitTwo GoTo NeverBeHere
On Nmber(255) GoTo NeverBeHere
On -0.5 GoTo NeverBeHere
On 255.49999 GoTo NeverBeHere

' Going somewhere the first ____ evaluates to 1 so I GoTo
On 1 GoTo 10
MsgBox prompt:="I am never here. You will never see this"
10 On 1.49999 GoTo 20
MsgBox prompt:="I am never here. You will never see this"
20 On Nmber(0.5001) GoTo 30
MsgBox prompt:="I am never here. You will never see this"
30 Exit Sub
'
NeverBeHere:
' I will never be here
MsgBox prompt:="I am never here. You will never see this"
End Sub
Function TwitTwo() As Double
Let TwitTwo = 2.1
End Function
Function Nmber(ByVal No As Double) As Double
Let Nmber = No
End Function

[DocAElstein]

Post for later use

[DocAElstein]

Some notes from this question:
http://www.eileenslounge.com/viewtopic.php?p=281312#p281312
Yasser Question.JPG

Question …
http://www.eileenslounge.com/viewtopic.php?f=30&t=36224
http://i.imgur.com/Ot6o46f.jpg
_____ Workbook: Extract missing dates for each person.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHITUV
1NameDatesHelperCheck DatesResultaaYasser Given

2aa2021-02-192021-02-192021-01-262021-01-262021-01-292021-01-29

3aa2021-01-262021-01-262021-01-272021-01-272021-01-302021-01-30

4aa2021-01-272021-01-272021-01-282021-01-282021-02-052021-02-05

5aa2021-01-282021-01-282021-01-29Missing2021-02-122021-02-12

6aa2021-01-312021-01-312021-01-30Missing

7aa2021-02-012021-02-012021-01-312021-01-31

8aa2021-02-022021-02-022021-02-012021-02-01

9aa2021-02-032021-02-032021-02-022021-02-02

10aa2021-02-042021-02-042021-02-032021-02-03

11aa2021-02-062021-02-062021-02-042021-02-04

12aa2021-02-072021-02-072021-02-05Missing

13aa2021-02-082021-02-082021-02-062021-02-06

14aa2021-02-092021-02-092021-02-072021-02-07

15aa2021-02-102021-02-102021-02-082021-02-08

16aa2021-02-112021-02-112021-02-092021-02-09

17aa2021-02-132021-02-132021-02-102021-02-10

18aa2021-02-142021-02-142021-02-112021-02-11

19aa2021-02-152021-02-152021-02-12Missing

20aa2021-02-162021-02-162021-02-132021-02-13

21aa2021-02-172021-02-172021-02-142021-02-14

22aa2021-02-182021-02-182021-02-152021-02-15

23aa2021-02-202021-02-202021-02-162021-02-16

24aa2021-02-212021-02-212021-02-172021-02-17

25aa2021-02-222021-02-222021-02-182021-02-18

26aa2021-02-232021-02-232021-02-192021-02-19

27aa2021-02-242021-02-242021-02-202021-02-20

28aa2021-02-252021-02-252021-02-212021-02-21

29bb2021-01-272021-01-272021-02-222021-02-22

30bb2021-01-282021-01-282021-02-232021-02-23

31bb2021-01-312021-01-312021-02-242021-02-24

32bb2021-02-012021-02-012021-02-252021-02-25

33bb2021-02-032021-02-03
Worksheet: Sheet1

[DocAElstein]

Continued from last post: Some notes from this question:
http://www.eileenslounge.com/viewtopic.php?p=281312#p281312
Yasser Question.JPG https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15418&viewfull=1#post15418

Hans Solution. What’s he doing:

Rem 1 Make dictionary of Dictionaries2
There are two dictionary variables.
The first one contains all the unique name values from column A . So this is the unique names dictionary
We loop down to build that dictionary, and the solution is relying on a un unbroken sequential list of names, in other words no mixed up , but an order list like
Name1
Name1
Name1
Name2
Name2
..etc.
In that main loop , all the values, from column B are put in the Item ( which is itself a dictionary ) of each unique name in the unique names dictionary.
This is the clever line that does that. The line is done for each row in the data to be looked in ( column B )
Let dct1(rng1(r1, 1))(Int(rng1(r1, 2))) = 1
The 1 is arbitrary. What we are doing is like referring to ( trying to put 1 into ) the key of an item in the second dictionary that does not exist. When this is done, rather than error, the Scripting.Dictionary is programmed to make an item with that key.
The end result of all this is that we end up with a main dictionary that has a key for each unique name. The item for each name / Key has a second dictionary in it of all the Integer parts of the Date & time in column B. ( The dictionary will be seeing the basic Excel .Vaue2 of the date & time, so the Integer part will be just the date.
Here is a pseudo couple of code lines to demo that last bit

Dick1(Name1) ( 2021-02-19 ) = 1
Dick1(Name1) ( 2021-01-26 ) = 1

You see what’s going on is the following:
Dick1(Name1) will always return the same thing which is the Item in Dick1 with the Key of Name1
So Effectively those lines are pseudo

Dick2 ( 2021-02-19 ) = 1
Dick2 ( 2021-01-26 ) = 1

What those code lines try to do is put a 1 in the items of a Dick2 element that does not exist. As noted, the Scripting.Dictionary is programmed to make an item with that key rather than error if such an action is attempted.
So that is just a convenient way to make the second dictionaries – Note I said dictionaries

We end up with this:
Dick1 keys
http://i.imgur.com/zTWYpuy.jpg


Dick2KeysWichAreDicksInDick1Items.jpg
http://i.imgur.com/Jsd2kXS.jpg

These lines give me that from doing a Shift F9 on any variable
Shift F9 on vTemps for Watch Window.JPG http://i.imgur.com/Ms7HmG6.jpg



Rem 2
We have an Outer loop and an inner loop in it.
__The outer loop is done once for each unique name, so for each key of the main dictionary
____The inner loop goes down the entire F column Check dates and does a write out any missing dates, that is to say dates not in the dictionary that is the item for that unique name, key of the main dictionary



Hans macro

Option Explicit
Sub ListMissing() ' ' Hans http://www.eileenslounge.com/viewtopic.php?p=281312#p281312
Dim vTemp1, vTemp2 ' For development and debug
Dim wsh1 As Worksheet
Dim wsh2 As Worksheet
Dim rng1 As Variant
Dim rng2 As Variant
Dim m1 As Long
Dim m2 As Long
Dim r1 As Long
Dim r2 As Long
Dim r3 As Long
Dim dct1 As Object
Dim dcTemp2 As Object
Dim n As Variant
Set dct1 = CreateObject("Scripting.Dictionary")
Set wsh1 = Worksheets("Sheet1")
Let m1 = wsh1.Range("A" & wsh1.Rows.Count).End(xlUp).Row
Let rng1 = wsh1.Range("A2:B" & m1).Value
Rem 1 Make dictionary of Dictionaries
For r1 = 1 To UBound(rng1)
If Not dct1.Exists(rng1(r1, 1)) Then ' this gives us 3 elements in the dct1 that have like key aa and the item is an empty dictionary object
Set dcTemp2 = CreateObject("Scripting.Dictionary") ' This effectively clears the variable used temporarily
dct1.Add Key:=rng1(r1, 1), Item:=dcTemp2
End If
Let dct1(rng1(r1, 1))(Int(rng1(r1, 2))) = 1 ' the 1 is arbritrary, we effectively create a Key looking like aa 2021-02-19 in the second dictionary that is the item of the unique
Next r1
vTemp1 = dct1.keys() ' Dick1.JPG http://i.imgur.com/zTWYpuy.jpg
vTemp2 = dct1.items() ' Dick2KeysWichAreDicksInDick1Items.jpg http://i.imgur.com/Jsd2kXS.jpg
'
Let m2 = wsh1.Range("F" & wsh1.Rows.Count).End(xlUp).Row
Let rng2 = wsh1.Range("F2:F" & m2).Value
'
Set wsh2 = Worksheets("Sheet2Hans")
wsh2.Range("A2:B" & wsh2.Rows.Count).Clear


Rem 2 Go through checking for existance of an Item. For no existance , then that is missing data
Let r3 = 1
' The outer loop is done once for each unique name, so for each key of the main dictionary ===========
For Each n In dct1.keys ' this and next line make it For Each of .._
Set dcTemp2 = dct1(n) ' _.. the dictionries within each item of Dick1 In other words For Each Name
' -----------------------------------------------
' The inner loop goes down the entire F column Check dates and does a write out any missing dates, that is to say dates not in the dictionary that is the item for that unique name, key of the main dictionary
For r2 = 1 To UBound(rng2) ' Going down the entire F range
If Not dcTemp2.Exists(rng2(r2, 1)) Then
Let r3 = r3 + 1
Let wsh2.Range("A" & r3).Value = n ' n is the key, the unique name, in the main large dictionary
Let wsh2.Range("B" & r3).Value = rng2(r2, 1) ' This will be the missing entry
Else
End If
Next r2 ' ________________________________________

Next n ' ================================================== ============================================
End Sub

[DocAElstein]

Some notes for this question:
http://www.eileenslounge.com/viewtopic.php?p=281291#p281291

For example, this bit …. using formulas like that
=IFERROR(INDEX($A$2:$C$1000,MATCH(1,($A$2:$A$1000= $I$1)*($C$2:$C$1000=F2),0),3),"Missing")
Then I manually filter by Missing and copied the results…..
That can be done in a single code line, …. _

Sub BasicOneLine() ' '.... http://www.eileenslounge.com/viewtopic.php?p=281291#p281291
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace(Join(Appli cation.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")")), 1), 1), 1).Value = _
Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace(Join(Appli cation.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")")), 1)
End Sub



Before
_____ Workbook: Extract missing dates for each person.xlsm ( Using Excel 2007 32 bit )
Row\ColITUV
1aaYasser Given

22021-01-29

32021-01-30

42021-02-05

52021-02-12

6
Worksheet: Sheet1

After
_____ Workbook: Extract missing dates for each person.xlsm ( Using Excel 2007 32 bit )
Row\ColITUV
1aaYasser Given

22021-01-292021-01-29

32021-01-302021-01-30

42021-02-052021-02-05

52021-02-122021-02-12

6
Worksheet: Sheet1

Run Sub BasicOneLine() on the uploaded file to demo those results

[DocAElstein]

extended coding notes for last post
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15420&viewfull=1#post15420


Sub Pretty2() '
Dim arrTemp() As Variant
Rem To get the results in column T ( same as
' Ths first forumula give me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' The next few lines get rid of the 0s
Dim StrTemp As String: Let StrTemp = Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare): StrTemp = Replace(StrTemp, "0#", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

' Or

Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace(Join(Appli cation.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")")), 1), 1), 1).Value = _
Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace(Join(Appli cation.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")")), 1)






Stop

' Replace(Replace(Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", "")























Rem To get to Column N in Extract missing dates for each person.xlsm
' Ths first forumula give me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' The next step is to replace the errors with 0s
Let arrTemp() = Evaluate("=IFERROR(IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$ 2:$A$1000=$I$1),0)),0)") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' The next few lines get rid of the 0s
'Dim StrTemp As String
Let StrTemp = Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
'Dim arrStrTemp() As String
Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))
Let arrTemp() = Application.Index(Range("C2:C463"), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match
Let Range("N2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("N2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"




' Or





' Let arrTemp() = Evaluate("=If({1},IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$ 1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0) )")


'let worksheets("Sheet2").range
'v = Join(v, "#") ' https://www.vbarchiv.net/commands/cmd_filter.html
'
'
'v = Application.Index(Range("C2:C463"), Evaluate("=If({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0)*($A$2:$A$1000=$I$1))"), 1)
'
'
'v = Application.Index(v, Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
'v = Evaluate("=IFERROR(INDEX($A$2:$C$1000,MATCH(1,($A$2:$A$1000= $I$1)*($C$2:$C$1000=" & r.Address & "),0),3),""Missing"")")
'
End Sub
Sub BasicOneLine() ' '.... http://www.eileenslounge.com/viewtopic.php?p=281291#p281291

[DocAElstein]

This is a slightly more sane version of the single line macro idea from here
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15420&viewfull=1#post15420
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15421&viewfull=1#post15421


Sub SlightlySanerVersion()
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Replace(Replace(Join(Application.Index(Evalu ate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "0#", ""), "#0", ""), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)

Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
' Or
Dim UnicNm As String: Let UnicNm = "aa"
Let arrStrTemp() = Split(Replace(Replace(Join(Application.Index(Evalu ate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & UnicNm & """" & "),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "0#", ""), "#0", ""), "#")
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)

Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
End Sub

We can use the basic idea above to make a function idea to do the same


Sub UseNotSoInsaneFunction()
Dim arrTemp() As Variant
Let arrTemp() = NotSoInsane("aa")
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
End Sub


Function NotSoInsane(ByVal Nme As String) As Variant
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Replace(Replace(Join(Application.Index(Evalu ate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & Nme & """" & "),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "0#", ""), "#0", ""), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let NotSoInsane = arrTemp()
End Function

[DocAElstein]

In support of these Threads and posts
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15421&viewfull=1#post15421
http://www.eileenslounge.com/viewtopic.php?f=30&t=36224

A problem arose with testing with bb

_____ Workbook: Extract missing dates for each person bb.xlsm ( Using Excel 2007 32 bit )
Row\ColTUVWXYZ
1Yasser GivenHans ResultsIndicies

22021-01-262021-01-292021-01-292

32021-01-302021-01-300

42021-02-052021-02-050

52021-01-292021-02-122021-02-125

62021-01-302021-01-262021-01-266

72021-01-292021-01-290

82021-01-302021-01-300

92021-02-022021-02-022021-02-029

102021-02-050

112021-02-120

122021-02-052021-02-0512

132021-02-160

142021-02-190

152021-02-250

160

170

180

192021-02-122021-02-1219

202021-02-1320

210

222021-02-1522

232021-02-162021-02-1623

240

250

262021-02-192021-02-1926

270

280

290

300

310

322021-02-252021-02-2532

332021-01-290
Worksheet: Sheet1

If you examine above my ( wrong) results in column T against Hans results in column V and
then look at the Debug / Immediate window info below for
before ( http://i.imgur.com/M3laahV.jpg )
and
after ( http://i.imgur.com/RUPIWIg.jpg ), where I take out the unwanted data from a text string , .._

? strtemp
2#0#0#5#6#0#0#9#0#0#12#0#0#0#0#0#0#19#20#0#22#23#0 #0#26#0#0#0#0#0#32#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0

? strtemp
2#5#6#9#12#19#222#23#26#32
_...then I can see the problem and where its coming from:

The problem is that I chose to remove the unwanted data
_ first by removing all #0 - that works fine, no problem with that as I am not expecting any real data starting with a 0
_ second I allow for the case of unwanted data at the start by removing all 0# - this can cause problems as it has in this example – It has resulted for example in this
#20#0#22
becoming this
#20#22
And then when after , (or previously) the 0# is removed/ was removed, the final result is
#222
So I loose the valid data of 20 and 22 and get a wrong data of 222 ( and in the test data, indicial 222 matches to an empty cell )
The final outcome is I loose two final date values and gain an extra unwanted empty ( nonsense date zero value ) date


There are thousands of easy ways to solve this problem , with various If Then ways. But these will “interrupt the flow” as it were, leading to inefficiency and prevent me building my final one line code way.

This first element problem is one I often refer to as an awkward bollock
Variations of this come up a lot. Often an efficient cure to this awkward bollock is to include an extra separator at the start. This wont quite for us in the case of this data, but almost.
The following variation seems OK
Consider these two lines, where the awkward bollock is dealt with second

' The next few lines get rid of the 0s
Dim StrTemp As String: Let StrTemp = Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "#0", "", 2, -1, vbBinaryCompare): StrTemp = Replace(StrTemp, "0#", "", 1, -1, vbBinaryCompare) ' This effectively removes the 0s data ( and its seperator )
Solution:
I add some arbitrary character at the start
StrTemp = "_" & Join(arrTemp(), "#")
That wont add much extra overhead
Now deal with the awkward bollock first
StrTemp = Replace(StrTemp, "_0#", "_" ………..
That has done no extra work, just done an existing step a bit differently

So far nothing so clever. The next part allows us to do no, or little, extra work by taking advantage of a little known extra argument of the Replace
The forth (optional) argument of Replace lets us say at which character point in the original we start our returned string. That may confuse, so let me say that again with an example..
I have this xy-z-2 and I want this yz2
Most people would think they need
either
_ two Replaces , one to take out – and the other to take out x
or
_ a Replace to take out – and then some other process or function to take out the first character.

But if we choose 2 in our forth argument of the Replace that takes out the - , then our returned string will effectively have the first character removed.

' The next few lines get rid of the 0s
Dim StrTemp As String: Let StrTemp = "_" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "_0#", "_", 1, 1, vbBinaryCompare): StrTemp = Replace(StrTemp, "#0", "", 2, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )


That seems to solve the problem
strTempAfterProblemSolved.JPG
http://i.imgur.com/Dgu8NE1.jpg

Full macro in next post

[DocAElstein]

Full macro for last post


Sub Pretty3bbProbSolved() ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15426&viewfull=1#post15426
Dim arrTemp() As Variant
Rem To get the results in column T ( same as
' Ths first forumula give me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' Or
Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))

' The next few lines get rid of the 0s
Dim StrTemp As String: Let StrTemp = "_" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "_0#", "_", 1, 1, vbBinaryCompare): StrTemp = Replace(StrTemp, "#0", "", 2, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or
Let arrStrTemp() = Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#")
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution

Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

' Or
Let arrStrTemp() = Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#")
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
' Or
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")")), 1), 1), 1).Value = _
Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")")), 1)

End Sub

[DocAElstein]

I am not quite sure what got in my brain in the last post. With hind site most of what I said and done is crap. But maybe later I will twig to what was going on.

I will start again…. Or rather pick it up where I went off course…._ I have …_
_.... an awkward bollock
Variations of this come up a lot. Often an efficient cure to this awkward bollock is to include an extra separator at the start.

The general solution is fine. After adding a separator, #, at the start, I remove all #0
All is well and then I only need to get rid finally of a single # I don’t need at the start.
For that last thing, Mid(StrTemp,2) would do. So would a second Replace in this form Replace(StrTemp, "#", "", 1, 1…. Or Replace(StrTemp, "#", "", , 1….
In the Replace.. we are using the 5th (optional ) argument to restrict us to removing a single # and the convention is to start from the left so that will hit on the first.

In this complete version I use the Mid(StrTemp,2) way


Option Explicit
Sub Pretty3bbaa() '
Dim arrTemp() As Variant
Rem To get the results in column T ( same as Yassers or Hans Results
' Ths first forumula gives me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' Or
Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))

' The next few lines get rid of the 0s ( 2 lines commented out to prevent the shortened line messing up )
Dim StrTemp As String: Let StrTemp = "#" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data. The extra # allows us to remove all 0 entries via removing all #0 Without this we might get one left at the start
' Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
' Let StrTemp = Mid(StrTemp, 2) ' Because I omit the third optional ( length ) argument I get all the remaing string after the first one. This effectively takes off the extra # which I don't need
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or ,
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
'
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

End Sub
Sub SlightlySanerVersion()
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
' Or
Dim UnicNm As String: Let UnicNm = "aa" ' "aa"
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & UnicNm & """" & "),0)*($A$2:$A$1000=" & """" & UnicNm & """" & ")),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
End Sub

[DocAElstein]

I can sanitise the last version a bit and come up with a simple function to get you an array of your missings, where the function takes the unique name, ( the unique name in the test data is the things like aa bb cc etc. )


Sub SlightlySanerVersion()
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
' Or
Dim UnicNm As String: Let UnicNm = "aa" ' "aa"
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & UnicNm & """" & "),0)*($A$2:$A$1000=" & """" & UnicNm & """" & ")),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
End Sub
Sub UseNotSoInsaneFunction()
Dim arrTemp() As Variant
Let arrTemp() = NotSoInsane("bb")
' Columns("T:T").ClearContents ' Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd"
End Sub
Function NotSoInsane(ByVal Nme As String) As Variant
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & Nme & """" & "),0)*($A$2:$A$1000=" & """" & Nme & """" & ")),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let NotSoInsane = arrTemp()
End Function
'

[DocAElstein]

Post for later use

[DocAElstein]

If I use a Transpose function at one place instead of my preferred Index way of transposing things, then I can reduce it to a single code line: This for example will get your pasted results for the unique “aa” Missings

Sub SingleLineWithTranspose()
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)
End Sub


Here are some of the full workings used to get that single code line:


Sub Pretty3bbaaTranspose() '
Dim arrTemp() As Variant
Rem To get the results in column T ( same as Yassers or hans Results
' Ths first forumula gives me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' Or
Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))

' The next few lines get rid of the 0s ( 2 lines commented out to prevent the shortened line messing up )
Dim StrTemp As String: Let StrTemp = "#" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data. The extra # allows us to remove all 0 entries via removing all #0 Without this we might get one left at the start
' Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
' Let StrTemp = Mid(StrTemp, 2) ' Because I omit the third optional ( length ) argument I get all the remaing string after the first one. This effectively takes off the extra # which I don't need
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or ,
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")


' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Transpose(arrStrTemp())
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(arrStrTemp()), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)


Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"


Stop
' Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

End Sub
Sub SingleLineWithTranspose()
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)
End Sub

[DocAElstein]

post for latzer use


View North from Balcony .. a castle I don’t know the name of on the Horizon, ( the hook is part of the Father in Laws new elevator to lift up shopping etc to the Third floor
02_BalconyNorthAnotherCastleAndHookFromFatherInLaw sMotorisedLift.jpg : https://imgur.com/ZG6Dmg2

View South from Balcony – the famous Coburg Veste
03_BalconySouthVeste.jpg : https://imgur.com/uNnCO8F

View East from Balcony - Bavarian fairy land
06_PrettyViewEast.jpg : https://imgur.com/1DzYrL2

Beer Mugs: I don’t drink much, certainly not at home, and never when building. But with the Father in Law it has become a bit of a tradition .. a German beer or two.
04_CoburgBalconyBeerMugs.jpg : https://imgur.com/RDXq3HH

Our old Blue bus hidden in a back lane: View of the Veste from guest room, and at the bottom our old blue VW bus – we have to hide it as it does not fit in too well
05_GuestRoomCoburgVesteAndBlueVWBus.jpg : https://imgur.com/30B3nkp

A very bad picture or the Veste at night from the parents in law’s living room … Bavarian “Fairy land” – what a view to have..
08_VesteAtNight.jpg : https://imgur.com/5HrY1Hy

Finally, that ugly man spoiling the view again..
07_UglyManInPicture : https://imgur.com/Eic7NSD


View North from Balcony .. a castle I don’t know the name of on the Horizon, ( the hook is part of the Father in Laws new elevator to lift up shopping etc to the Third floor
02_BalconyNorthAnotherCastleAndHookFromFatherInLaw sMotorisedLift.jpg : http://i.imgur.com/ZG6Dmg2.jpg

View South from Balcony – the famous Coburg Veste
03_BalconySouthVeste.jpg : http://i.imgur.com/uNnCO8F.jpg

View East from Balcony - Bavarian fairy land
06_PrettyViewEast.jpg : http://i.imgur.com/1DzYrL2.jpg

Beer Mugs: I don’t drink much, certainly not at home, and never when building. But with the Father in Law it has become a bit of a tradition .. a German beer or two.
04_CoburgBalconyBeerMugs.jpg : http://i.imgur.com/RDXq3HH.jpg

Our old Blue bus hidden in a back lane: View of the Veste from guest room, and at the bottom our old blue VW bus – we have to hide it as it does not fit in too well
05_GuestRoomCoburgVesteAndBlueVWBus.jpg : http://i.imgur.com/30B3nkp.jpg

A very bad picture or the Veste at night from the parents in law’s living room … Bavarian “Fairy land” – what a view to have..
08_VesteAtNight.jpg : http://i.imgur.com/5HrY1Hy.jpg

Finally, that ugly man spoiling the view again..
07_UglyManInPicture : http://i.imgur.com/Eic7NSD.jpg

[DocAElstein]

In support of these post
https://eileenslounge.com/viewtopic.php?p=281384#p281384
https://eileenslounge.com/viewtopic.php?p=281383#p281383





Finally, If I use a simple Dictionary way to get your unique names from your column A, then I can incorporate my ideas into a full solution that gets the same results as Hans using your uploaded test data.
Rem 1 Gets your unique names from column A
Rem 2 Loops through those unique names and each time in the loop the Function is called to get an array of your missings.



Sub EvaluateRangeFormulaWay() ' http://www.eileenslounge.com/viewtopic.php?p=281315#p281315
Rem 0 worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1"): Set Ws2 = ThisWorkbook.Worksheets.Item("Sheet2Alan")
Dim Em1 As Long: Let Em1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA1() As Variant: Let arrA1() = Ws1.Range("A1:A" & Em1 & "").Value2 ' All names list
Rem 1
Dim Dik1 As Object: Set Dik1 = CreateObject("Scripting.Dictionary")
' 1b) make list of unique names
Dim Cnt
For Cnt = 2 To Em1 ' Looping down all names
Let Dik1(arrA1(Cnt, 1)) = "This can be anything you like, it don't really matter. What happens here is that we try to put this text in the Item of a dictionary entry that has the key of the value of arrA1(Cnt, 1) If that entry does not exist, then the dictionary is programmed not to error , but instead make ( Add ) an entry with that key value. For our purposes we don't care what the items are. But at the end of this loop we will have effectively Added a element in the dictionary, one for each of the unique name values. We can then use the Keys() array as a convenient way to get an array of unique names"
Next Cnt
Dim arrUnics() As Variant: Let arrUnics() = Dik1.Keys() ' This is an array of our unique Names
Rem 2 Do it
Dim R3Lne As Long: Let R3Lne = 2 ' This is the next free line in second worksheet
For Cnt = 0 To UBound(arrUnics()) ' looping through all uniques names
Dim arrMisins() As Variant: Let arrMisins() = Missings(arrUnics(Cnt)) '## Go to the function that makes an array of the Missing dates based on the Name value
Dim NoMisins As Long: Let NoMisins = UBound(arrMisins(), 1)
Let Ws2.Range("A" & R3Lne & ":A" & R3Lne + (NoMisins - 1) & "").Value = arrUnics(Cnt) ' Put the name in as many cells as we have missing dates
Let Ws2.Range("B" & R3Lne & ":B" & R3Lne + (NoMisins - 1) & "").Value = arrMisins() ' Put the missing dates in
Let R3Lne = R3Lne + NoMisins ' This is the next free line in second worksheet
Next Cnt

Let Ws2.Range("B2:B" & Ws2.UsedRange.Rows.Count + 1 & "").NumberFormat = "yyyy/mm/dd"
End Sub
Function Missings(ByVal Nme As String) As Variant
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Worksheets("Sheet1").Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & Nme & """" & "),0)*($A$2:$A$1000=" & """" & Nme & """" & ")),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Missings = arrTemp()
End Function








Sub TestFunctionMissings()
Dim arrTemp() As Variant
Let arrTemp() = Missings("bb")
' Columns("T:T").ClearContents ' Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd"
End Sub

[DocAElstein]

I have done another couple of versions, just out of interest.

I have also adjusted the code to be the same last row, but in these two versions the last row is not hard coded. I am using the last row of data. So that is found dynamically in the usual way.

Because we use the same last row, I can simplify a few things.

The difference between the two new versions is that
_ one uses the conventional Transpose function to do a couple of transposing.
_ In the other one, the same transposing is done in that strange Index function way that I personally like to do.


Index Function Way

' Using the Index way for the tranposing
Sub Pretty3d() '
Rem 0 worksheets info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1")
Dim M As Long: Let M = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row


Dim arrTemp() As Variant
Rem To get the results in column T ( same as Yassers or Hans Results
' Ths first forumula gives me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F" & M & ",Int(B2:B" & M & "),0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F" & M & ",Int(B2:B" & M & ")*($A$2:$A$1000=$I$1),0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F" & M & "=0,0,MATCH(F2:F" & M & ",C2:C" & M & "*(A2:A" & M & "=I1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")"))
' Or
' Let arrTemp() = Application.Transpose(arrTemp())

Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")"))

' The next few lines get rid of the 0s ( 2 lines commented out to prevent the shortened line messing up )
Dim StrTemp As String: Let StrTemp = "#" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data. The extra # allows us to remove all 0 entries via removing all #0 Without this we might get one left at the start
' Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
' Let StrTemp = Mid(StrTemp, 2) ' Because I omit the third optional ( length ) argument I get all the remaing string after the first one. This effectively takes off the extra # which I don't need
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or ,
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")")), "#"), "#0", ""), 2), "#")
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))

Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' or
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)


Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"
Stop
' Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

End Sub
Sub ShortPretty3d()
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")")), "#"), "#0", ""), 2), "#")
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
End Sub
Function ShortPretty3dFunction(ByVal Nme As String) As Variant
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=" & """" & Nme & """" & "),0)*(A2:A" & M & "=" & """" & Nme & """" & ")),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")")), "#"), "#0", ""), 2), "#")
Let ShortPretty3dFunction = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
End Function
Sub TestShortPretty3dFunction()
Dim arrTemp() As Variant
Let arrTemp() = ShortPretty3dFunction("aa")
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd"
End Sub
















see next post
Transpose Function Way

[DocAElstein]

Transpose Function Way




' Using Transpose for the transposing
Sub Pretty3dTranspose() '
Rem 0 worksheets info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1")
Dim M As Long: Let M = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row


Dim arrTemp() As Variant
Rem To get the results in column T ( same as Yassers or Hans Results
' Ths first forumula gives me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F" & M & ",Int(B2:B" & M & "),0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F" & M & ",Int(B2:B" & M & ")*($A$2:$A$1000=$I$1),0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F" & M & "=0,0,MATCH(F2:F" & M & ",C2:C" & M & "*(A2:A" & M & "=I1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction which annoyingly on work on 1 D arrays, so we convert it by a transpose in the next code line
'Let arrTemp() = Application.Transpose(arrTemp())
' Or
Let arrTemp() = Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"))


' The next few lines get rid of the 0s ( 2 lines commented out to prevent the shortened line messing up )
Dim StrTemp As String: Let StrTemp = "#" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data. The extra # allows us to remove all 0 entries via removing all #0 Without this we might get one left at the start
' Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
' Let StrTemp = Mid(StrTemp, 2) ' Because I omit the third optional ( length ) argument I get all the remaing string after the first one. This effectively takes off the extra # which I don't need
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or ,
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")
' We need a "vertical" array for output, so we transpose to the original orientation, and I need a variant type for that regardless of if i use the in built Transpose way or my preferred Index way since both those will return elements in Variant type
Let arrTemp() = Application.Transpose(arrStrTemp())
' Or
Let arrTemp() = Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#"))
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(arrStrTemp()), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
' Or
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)

Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

End Sub
Sub SingleLinePretty3dTranspose()
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)
End Sub

Function ShortPretty3dFunctionTranspose(ByVal Nme As String) As Variant
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Let ShortPretty3dFunctionTranspose = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=" & """" & Nme & """" & "),0)*(A2:A" & M & "=" & """" & Nme & """" & ")),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)
End Function
Sub TestShortPretty3dFunctionTranspose()
Dim arrTemp() As Variant
Let arrTemp() = ShortPretty3dFunctionTranspose("aa")
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd"
End Sub

[DocAElstein]

Some extra solutions for this Thread
https://excelfox.com/forum/showthread.php/2738-PQ-make-new-column-by-extracting-a-word-from-a-cell-that-contains-a-sign



Excel Solution
_____ Workbook: TextWith$InIt.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLM
15465 Apples$50 Twenty =FIND("$",A1)=LEFT(A1,B1)=FIND(" ",C1)=RIGHT(C1,LEN(C1)-D1)=RIGHT(A1,LEN(A1)-B1)=FIND(" ",F1)=LEFT(F1,G1-1)=E1&H1=RIGHT(LEFT(A1,FIND("$",A1)),LEN(LEFT(A1,FIND("$",A1)))-FIND(" ",LEFT(A1,FIND("$",A1))))&LEFT(RIGHT(A1,LEN(A1)-FIND("$",A1)),FIND(" ",RIGHT(A1,LEN(A1)-FIND("$",A1)))-1)Apples$50Apples$50

25687 Grapes$597 Three =FIND("$",A2)=LEFT(A2,B2)=FIND(" ",C2)=RIGHT(C2,LEN(C2)-D2)=RIGHT(A2,LEN(A2)-B2)=FIND(" ",F2)=LEFT(F2,G2-1)=E2&H2=RIGHT(LEFT(A2,FIND("$",A2)),LEN(LEFT(A2,FIND("$",A2)))-FIND(" ",LEFT(A2,FIND("$",A2))))&LEFT(RIGHT(A2,LEN(A2)-FIND("$",A2)),FIND(" ",RIGHT(A2,LEN(A2)-FIND("$",A2)))-1)Grapes$597Grapes$597
Worksheet: Sheet2
_____ Workbook: TextWith$InIt.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLM
15465 Apples$50 Twenty 125465 Apples$5Apples$50 Twenty 350Apples$50Apples$50Apples$50Apples$50

25687 Grapes$597 Three 125687 Grapes$5Grapes$597 Three 4597Grapes$597Grapes$597Grapes$597Grapes$597
Worksheet: Sheet2



Some VBA Solutions


Option Explicit
' https://excelfox.com/forum/showthread.php/2738-PQ-make-new-column-by-extracting-a-word-from-a-cell-that-contains-a-sign https://www.mrexcel.com/board/threads/power-query-make-new-column-by-extracting-a-word-from-a-cell-that-contains-a-sign.1165642/
Sub Frm1a() '
Dim vTemp As Variant ' =RIGHT(LEFT(A1,FIND(""$"",A1)),LEN(LEFT(A1,FIND(""$"",A1)))-FIND("" "",LEFT(A1,FIND(""$"",A1))))&LEFT(RIGHT(A1,LEN(A1)-FIND(""$"",A1)),FIND("" "",RIGHT(A1,LEN(A1)-FIND(""$"",A1)))-1)
Let vTemp = Evaluate("=RIGHT(LEFT(A1,FIND(""$"",A1)),LEN(LEFT(A1,FIND(""$"",A1)))-FIND("" "",LEFT(A1,FIND(""$"",A1))))&LEFT(RIGHT(A1,LEN(A1)-FIND(""$"",A1)),FIND("" "",RIGHT(A1,LEN(A1)-FIND(""$"",A1)))-1)")
Debug.Print vTemp ' http://i.imgur.com/LARD8FB.jpg
Dim Rng As Range: Set Rng = Range("A1")
Let vTemp = Evaluate("=RIGHT(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")),LEN(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")))-FIND("" "",LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & "))))&LEFT(RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")),FIND("" "",RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")))-1)")
'Set Rng = Range("A1:A2")
' Let vTemp = Evaluate("=RIGHT(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")),LEN(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")))-FIND("" "",LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & "))))&LEFT(RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")),FIND("" "",RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")))-1)")
End Sub
Sub Frm1b()
Dim Rng As Range
For Each Rng In Range("A1:A2")
Let Rng.Offset(0, 11).Value = Evaluate("=RIGHT(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")),LEN(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")))-FIND("" "",LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & "))))&LEFT(RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")),FIND("" "",RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")))-1)")
Next Rng
End Sub
Sub Frm2a()
Dim Rng As Range
For Each Rng In Range("A1:A2")
Dim vTemp As Variant, vTemp1 As Variant, vTemp2 As Variant
Let vTemp = Split(Rng.Value, "$", -1, vbBinaryCompare)
Let vTemp2 = Left(vTemp(1), InStr(1, vTemp(1), " ", vbBinaryCompare) - 1)
Let vTemp1 = Split(vTemp(0), " ", -1, vbBinaryCompare)
Let vTemp1 = vTemp1(UBound(vTemp1))
Let vTemp = vTemp1 & "$" & vTemp2
Next Rng
End Sub
Sub Frm2b()
Dim Rng As Range
For Each Rng In Range("A1:A2")
Dim vTemp As Variant ' , vTemp1 As Variant, vTemp2 As Variant
Let vTemp = Split(Rng.Value, "$")
'Let vTemp2 = Left(vTemp(1), InStr(vTemp(1), " ") - 1)
'Let vTemp1 = Split(vTemp(0), " ")
'Let vTemp1 = Split(vTemp(0), " ")(UBound(Split(vTemp(0), " ")))
'Let vTemp = Split(vTemp(0), " ")(UBound(Split(vTemp(0), " "))) & "$" & Left(vTemp(1), InStr(vTemp(1), " ") - 1)
Let Rng.Offset(0, 12).Value = Split(vTemp(0), " ")(UBound(Split(vTemp(0), " "))) & "$" & Left(vTemp(1), InStr(vTemp(1), " ") - 1)
Next Rng
End Sub

[DocAElstein]

Some note from following info from pconlife.com
Downloading some of their files
Info from here
All file info https://www.pconlife.com/fileinfo/winhlp32.exe-info/#howdownloadandusefile



I initially downloaded some of the zipped winhlp32.exe files, tried on several different computers to open/unzip them . None of the downloaded files will open or unzip. The error is always the same “ Invalid file” http://i.imgur.com/hthN74l.jpg
I followed their advice to try 7.zip , a free Open source program http://www.7-zip.org/

In the following posts I have the
_ downloaded zip file
_ The unzipped exe ( using 7.zip )
_ a re zipped in windows version of that unzipped exe

[DocAElstein]

Windows XP Home Edition x32 Service Pack3:
5.1.2600.0 Download : https://www.pconlife.com/download/winosfile/1024/1/37b726c72699456bf34134c2bb89727a/

FileVersionFile Md5File SizeFile BitFile
5.1.2600.0 (XPClient.010817-1148) 37b726c72699456bf34134c2bb89727a 8K 32bit

unpacked files in the following path:
• • C:\Windows\system32\


_ Share ‘5 1 2600 0 WINHLP32 EXE.zip’ https://app.box.com/s/tkb7lz4hprmvp2bczwjyj59k2n1tl1h6
_ ** Share ‘5 1 2600 0 WINHLP32 EXE.exe’ https://app.box.com/s/fb0xyzjh7v7oo1bf8hv5r6r986pxeuod
_ Share ‘5 1 2600 0 WINHLP32 EXE Re Zip.zip’ https://app.box.com/s/m9a9huq67rd9pac923nbf3p48ajfmaed



5.1.2600.5512 Download :

FileVersionFile Md5File SizeFile BitFile
5.1.2600.5512 (xpsp.080413-0852) 65a9495a436f5402bc1c467e1b926c27 277K 32bit

unpacked files path:
• • C:\Windows\system32\dllcache\
• • C:\Windows\

_ Share ‘5 1 2600 5512 WINHLP32 EXE.zip’ https://app.box.com/s/tkb7lz4hprmvp2bczwjyj59k2n1tl1h6
_ ** Share ‘5 1 2600 5512 WINHLP32 EXE.exe’ https://app.box.com/s/rdrrs69mpimt2rh2usf5egr3yvadbizr
_ Share ‘5 1 2600 5512 WINHLP32 EXE Re Zip.zip’ https://app.box.com/s/3w2evt1rlq75j1rjfui6bx8qohmros9c



(** These are typical warnings that are shown after a 7.zip unzipping:
http://i.imgur.com/Zg2ZWAq.jpg
http://i.imgur.com/9r2rBVa.jpg 3553



Here are the final files that I have. I changed the names slightly to help distinguish between different winhlpexe files for different operating systems
http://i.imgur.com/HpEGeig.jpg
http://i.imgur.com/x00l1dj.jpg

[DocAElstein]

In support of this Thread
https://www.eileenslounge.com/viewtopic.php?f=30&t=36380


Excel 2003

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
16764057 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
16763904 $D$34
16777215 $E$34
16763904 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
52377 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
52377 $D$37
16777215 $E$37
52377 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
52377 $F$38
16777215 $G$38
16777215 $H$38

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
16764057 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
16763904 $D$34
16777215 $E$34
16763904 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
52377 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
52377 $D$37
16777215 $E$37
52377 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
52377 $F$38
16777215 $G$38
16777215 $H$38


16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
16764057 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
16763904 $D$34
16777215 $E$34
16763904 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
52377 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
52377 $D$37
16777215 $E$37
52377 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
52377 $F$38
16777215 $G$38
16777215 $H$38



The above .xls file in 2010

16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
****15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

[DocAElstein]

in support of this Thread post
https://www.eileenslounge.com/viewtopic.php?p=282274#p282274


16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
15261110 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

In one 2007 no interior color is shown ( there are errors in opening the .xlsb file ). For this same file saved as .xls I get in that 2007 this:

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
16777215 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
16777215 $D$34
16777215 $E$34
16777215 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
16777215 $D$35
16777215 $E$35
16777215 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
16777215 $D$36
16777215 $E$36
16777215 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
16777215 $D$37
16777215 $E$37
16777215 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
16777215 $D$38
16777215 $E$38
16777215 $F$38
16777215 $G$38
16777215 $H$38




16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
15261110 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

The above Excel with the .xls file version

16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
15261110 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

[DocAElstein]

In support of this post
https://www.eileenslounge.com/viewtopic.php?p=282275#p282275


16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
****15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
****15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38


In the above 2010 the following is from a .xls version of the file

16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
****15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

[DocAElstein]

From
https://eileenslounge.com/viewtopic.php?p=282284#p282284


16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
**** 15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

[DocAElstein]

Info from
https://eileenslounge.com/viewtopic.php?p=282295#p282295
https://eileenslounge.com/viewtopic.php?p=282297#p282297

hassona229

Excel 2010 32 bit
16777215 $A$1
16777215 $B$1
16777215 $C$1
16777215 $D$1
16777215 $E$1
16777215 $F$1
16777215 $G$1
16777215 $H$1
16777215 $A$2
16777215 $B$2
16777215 $C$2
16777215 $D$2
16777215 $E$2
16777215 $F$2
16777215 $G$2
16777215 $H$2
16777215 $A$3
16777215 $B$3
16777215 $C$3
16777215 $D$3
16777215 $E$3
16777215 $F$3
16777215 $G$3
16777215 $H$3
16777215 $A$4
16777215 $B$4
16777215 $C$4
16777215 $D$4
**** 15261367 ****** $E$4
16777215 $F$4
16777215 $G$4
16777215 $H$4
16777215 $A$5
16777215 $B$5
16777215 $C$5
16777215 $D$5
16777215 $E$5
16777215 $F$5
16777215 $G$5
16777215 $H$5
16777215 $A$6
16777215 $B$6
16777215 $C$6
16777215 $D$6
16777215 $E$6
16777215 $F$6
16777215 $G$6
16777215 $H$6
16777215 $A$7
16777215 $B$7
16777215 $C$7
16777215 $D$7
16777215 $E$7
16777215 $F$7
16777215 $G$7
16777215 $H$7
16777215 $A$8
16777215 $B$8
16777215 $C$8
16777215 $D$8
16777215 $E$8
16777215 $F$8
16777215 $G$8
16777215 $H$8
16777215 $A$9
16777215 $B$9
16777215 $C$9
16777215 $D$9
16777215 $E$9
16777215 $F$9
16777215 $G$9
16777215 $H$9
16777215 $A$10
16777215 $B$10
16777215 $C$10
16777215 $D$10
16777215 $E$10
16777215 $F$10
16777215 $G$10
16777215 $H$10
16777215 $A$11
16777215 $B$11
16777215 $C$11
16777215 $D$11
16777215 $E$11
16777215 $F$11
16777215 $G$11
16777215 $H$11
16777215 $A$12
16777215 $B$12
16777215 $C$12
16777215 $D$12
16777215 $E$12
16777215 $F$12
16777215 $G$12
16777215 $H$12
16777215 $A$13
16777215 $B$13
16777215 $C$13
16777215 $D$13
16777215 $E$13
16777215 $F$13
16777215 $G$13
16777215 $H$13
16777215 $A$14
16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
**** 15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20


Yasser's friend

Excel 2010 32 bit
16777215 $A$1
16777215 $B$1
16777215 $C$1
16777215 $D$1
16777215 $E$1
16777215 $F$1
16777215 $G$1
16777215 $H$1
16777215 $A$2
16777215 $B$2
16777215 $C$2
16777215 $D$2
16777215 $E$2
16777215 $F$2
16777215 $G$2
16777215 $H$2
16777215 $A$3
16777215 $B$3
16777215 $C$3
16777215 $D$3
16777215 $E$3
16777215 $F$3
16777215 $G$3
16777215 $H$3
16777215 $A$4
16777215 $B$4
16777215 $C$4
16777215 $D$4
**** 15261367 ****** $E$4
16777215 $F$4
16777215 $G$4
16777215 $H$4
16777215 $A$5
16777215 $B$5
16777215 $C$5
16777215 $D$5
16777215 $E$5
16777215 $F$5
16777215 $G$5
16777215 $H$5
16777215 $A$6
16777215 $B$6
16777215 $C$6
16777215 $D$6
16777215 $E$6
16777215 $F$6
16777215 $G$6
16777215 $H$6
16777215 $A$7
16777215 $B$7
16777215 $C$7
16777215 $D$7
16777215 $E$7
16777215 $F$7
16777215 $G$7
16777215 $H$7
16777215 $A$8
16777215 $B$8
16777215 $C$8
16777215 $D$8
16777215 $E$8
16777215 $F$8
16777215 $G$8
16777215 $H$8
16777215 $A$9
16777215 $B$9
16777215 $C$9
16777215 $D$9
16777215 $E$9
16777215 $F$9
16777215 $G$9
16777215 $H$9
16777215 $A$10
16777215 $B$10
16777215 $C$10
16777215 $D$10
16777215 $E$10
16777215 $F$10
16777215 $G$10
16777215 $H$10
16777215 $A$11
16777215 $B$11
16777215 $C$11
16777215 $D$11
16777215 $E$11
16777215 $F$11
16777215 $G$11
16777215 $H$11
16777215 $A$12
16777215 $B$12
16777215 $C$12
16777215 $D$12
16777215 $E$12
16777215 $F$12
16777215 $G$12
16777215 $H$12
16777215 $A$13
16777215 $B$13
16777215 $C$13
16777215 $D$13
16777215 $E$13
16777215 $F$13
16777215 $G$13
16777215 $H$13
16777215 $A$14
16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
**** 15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18

One of my XP 2010 machines

Excel 2010 32 bit
16777215 $A$1
16777215 $B$1
16777215 $C$1
16777215 $D$1
16777215 $E$1
16777215 $F$1
16777215 $G$1
16777215 $H$1
16777215 $A$2
16777215 $B$2
16777215 $C$2
16777215 $D$2
16777215 $E$2
16777215 $F$2
16777215 $G$2
16777215 $H$2
16777215 $A$3
16777215 $B$3
16777215 $C$3
16777215 $D$3
16777215 $E$3
16777215 $F$3
16777215 $G$3
16777215 $H$3
16777215 $A$4
16777215 $B$4
16777215 $C$4
16777215 $D$4
**** 15261367 ****** $E$4
16777215 $F$4
16777215 $G$4
16777215 $H$4
16777215 $A$5
16777215 $B$5
16777215 $C$5
16777215 $D$5
16777215 $E$5
16777215 $F$5
16777215 $G$5
16777215 $H$5
16777215 $A$6
16777215 $B$6
16777215 $C$6
16777215 $D$6
16777215 $E$6
16777215 $F$6
16777215 $G$6
16777215 $H$6
16777215 $A$7
16777215 $B$7
16777215 $C$7
16777215 $D$7
16777215 $E$7
16777215 $F$7
16777215 $G$7
16777215 $H$7
16777215 $A$8
16777215 $B$8
16777215 $C$8
16777215 $D$8
16777215 $E$8
16777215 $F$8
16777215 $G$8
16777215 $H$8
16777215 $A$9
16777215 $B$9
16777215 $C$9
16777215 $D$9
16777215 $E$9
16777215 $F$9
16777215 $G$9
16777215 $H$9
16777215 $A$10
16777215 $B$10
16777215 $C$10
16777215 $D$10
16777215 $E$10
16777215 $F$10
16777215 $G$10
16777215 $H$10
16777215 $A$11
16777215 $B$11
16777215 $C$11
16777215 $D$11
16777215 $E$11
16777215 $F$11
16777215 $G$11
16777215 $H$11
16777215 $A$12
16777215 $B$12
16777215 $C$12
16777215 $D$12
16777215 $E$12
16777215 $F$12
16777215 $G$12
16777215 $H$12
16777215 $A$13
16777215 $B$13
16777215 $C$13
16777215 $D$13
16777215 $E$13
16777215 $F$13
16777215 $G$13
16777215 $H$13
16777215 $A$14
16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
**** 15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19

[DocAElstein]

post for later use

[DocAElstein]

Some extra macros for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=36401
post
https://eileenslounge.com/viewtopic.php?p=282498#p282498



Option Explicit
Sub VergeltungswaffeV1V2() ' http://www.eileenslounge.com/viewtopic.php?f=27&t=36401
Dim Ar As Long, Em As Long
Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 ' The main data from column 1
Dim V1() As Variant, V2() As Variant: ReDim V1(1 To Em): ReDim V2(1 To Em) ' These will need to be variant because each element is itself an array ( a 1 D array )
For Ar = 1 To Em ' The main data rows range
Let V1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare) ' I am splitting each data into 2 bits, the first is the data ID the second is all the rest
Let V2(Ar) = Split(StrReverse(V1(Ar)(1)), " ", 6, vbBinaryCompare) ' We are splitting the reversed string, because my second data CITY might have a few words, I split the backward string in just enough bits so that the last element is the data CITY regardles of how many words are in it
Let V2(Ar)(0) = StrReverse(V2(Ar)(0)): V2(Ar)(1) = StrReverse(V2(Ar)(1)): V2(Ar)(2) = StrReverse(V2(Ar)(2)): V2(Ar)(3) = StrReverse(V2(Ar)(3)): V2(Ar)(4) = StrReverse(V2(Ar)(4)): V2(Ar)(5) = StrReverse(V2(Ar)(5)) ' The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
Next Ar
' The end result of the above is that we have two 1 D arrays, V1() and V2(). Each element is itself a 1 D array. We find that strangely that INDEX seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the Index(arr(), Rws(), Clms()) way to get out our final range in any order we like.
Let Range("B2:B" & Em + 1 & "").Value = Application.Index(V1(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
Let Range("C2:H" & Em + 1 & "").Value = Application.Index(V2(), Evaluate("=Row(1:" & Em & ")"), Array(6, 5, 4, 3, 2, 1)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
Range("A1:H1").EntireColumn.AutoFit
End Sub


Sub VergeltungswaffeV1V2_()
Dim Ar As Long, Em As Long
Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 ' The main data from column 1
Dim V1() As Variant, V2() As Variant: ReDim V1(1 To Em): ReDim V2(1 To Em) ' These will need to be variant because each element is itself an array ( a 1 D array )
For Ar = 1 To Em ' The main data rows range
Let V1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare) ' I am splitting each data into 2 bits, the first is the data ID the second is all the rest
Let V2(Ar) = Split(StrReverse(V1(Ar)(1)), " ", 6, vbBinaryCompare) ' We are splitting the reversed string, because my second data CITY might have a few words, I split the backward string in just enough bits so that the last element is the data CITY regardles of how many words are in it
Let V2(Ar) = Array(StrReverse(V2(Ar)(0)), StrReverse(V2(Ar)(1)), StrReverse(V2(Ar)(2)), StrReverse(V2(Ar)(3)), StrReverse(V2(Ar)(4)), StrReverse(V2(Ar)(5))) ' The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
Next Ar
' The end result of the above is that we have two 1 D arrays, V1() and V2(). Each element is itself a 1 D array. We find that strangely that INDEX seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the Index(arr(), Rws(), Clms()) way to get out our final range in any order we like.
Let Range("B2:B" & Em + 1 & "").Value = Application.Index(V1(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
Let Range("C2:H" & Em + 1 & "").Value = Application.Index(V2(), Evaluate("=Row(1:" & Em & ")"), Array(6, 5, 4, 3, 2, 1)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
Range("A1:H1").EntireColumn.AutoFit
End Sub

Sub VergeltungswaffeV1V2__()
Dim Ar As Long, Em As Long
Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 ' The main data from column 1
Dim V1() As Variant, V2() As Variant: ReDim V1(1 To Em): ReDim V2(1 To Em) ' These will need to be variant because each element is itself an array ( a 1 D array )
For Ar = 1 To Em ' The main data rows range
Let V1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare) ' I am splitting each data into 2 bits, the first is the data ID the second is all the rest
Let V2(Ar) = Split(StrReverse(V1(Ar)(1)), " ", 6, vbBinaryCompare) ' We are splitting the reversed string, because my second data CITY might have a few words, I split the backward string in just enough bits so that the last element is the data CITY regardles of how many words are in it
Let V2(Ar) = Array(StrReverse(V2(Ar)(5)), StrReverse(V2(Ar)(4)), StrReverse(V2(Ar)(3)), StrReverse(V2(Ar)(2)), StrReverse(V2(Ar)(1)), StrReverse(V2(Ar)(0))) ' The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
Next Ar
' The end result of the above is that we have two 1 D arrays, V1() and V2(). Each element is itself a 1 D array. We find that strangely that INDEX seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the Index(arr(), Rws(), Clms()) way to get out our final range in any order we like.
Let Range("B2:B" & Em + 1 & "").Value = Application.Index(V1(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
Let Range("C2:H" & Em + 1 & "").Value = Application.Index(V2(), Evaluate("=Row(1:" & Em & ")"), Array(1, 2, 3, 4, 5, 6)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
Range("A1:H1").EntireColumn.AutoFit
End Sub

[DocAElstein]

Some extra macros for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=36401
post
https://eileenslounge.com/viewtopic.php?p=282498#p282498



Option Explicit
Sub Dik1Dik2_() '
Dim Ar As Long, Em As Long
Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 ' The main data from column 1
Dim Dik1 As Object, Dik2 As Object: Set Dik1 = CreateObject("Scripting.Dictionary"): Set Dik2 = CreateObject("Scripting.Dictionary")
For Ar = 1 To Em ' The main data rows range
Let Dik1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare) ' I am splitting each data into 2 bits, the first is the data ID the second is all the rest
Let Dik2(Ar) = Split(StrReverse(Dik1(Ar)(1)), " ", 6, vbBinaryCompare) ' We are splitting the reversed string, because my second data CITY might have a few words, I split the backward string in just enough bits so that the last element is the data CITY regardles of how many words are in it
Let Dik2(Ar) = Array(StrReverse(Dik2(Ar)(0)), StrReverse(Dik2(Ar)(1)), StrReverse(Dik2(Ar)(2)), StrReverse(Dik2(Ar)(3)), StrReverse(Dik2(Ar)(4)), StrReverse(Dik2(Ar)(5))) ' The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
Next Ar
Dim v: v = Dik1.items()
' The end result of the above is that we have two 1 D arrays in the items of the dictionaries, one in each. Each element is itself a 1 D array. We find that strangely that INDEX seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the Index(arr(), Rws(), Clms()) way to get out our final range in any order we like.
Let Range("B2:B" & Em + 1 & "").Value = Application.Index(Dik1.items(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
Let Range("C2:H" & Em + 1 & "").Value = Application.Index(Dik2.items, Evaluate("=Row(1:" & Em & ")"), Array(6, 5, 4, 3, 2, 1)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
Range("A1:H1").EntireColumn.AutoFit
End Sub

Sub Dik1Dik2__() '
Dim Ar As Long, Em As Long
Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 ' The main data from column 1
Dim Dik1 As Object, Dik2 As Object: Set Dik1 = CreateObject("Scripting.Dictionary"): Set Dik2 = CreateObject("Scripting.Dictionary")
For Ar = 1 To Em ' The main data rows range
Let Dik1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare) ' I am splitting each data into 2 bits, the first is the data ID the second is all the rest
Let Dik2(Ar) = Split(StrReverse(Dik1(Ar)(1)), " ", 6, vbBinaryCompare) ' We are splitting the reversed string, because my second data CITY might have a few words, I split the backward string in just enough bits so that the last element is the data CITY regardles of how many words are in it
Let Dik2(Ar) = Array(StrReverse(Dik2(Ar)(5)), StrReverse(Dik2(Ar)(4)), StrReverse(Dik2(Ar)(3)), StrReverse(Dik2(Ar)(2)), StrReverse(Dik2(Ar)(1)), StrReverse(Dik2(Ar)(0))) ' The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
Next Ar
Dim v: v = Dik1.items()
' The end result of the above is that we have two 1 D arrays in the items of the dictionaries, one in each. Each element is itself a 1 D array. We find that strangely that INDEX seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the Index(arr(), Rws(), Clms()) way to get out our final range in any order we like.
Let Range("B2:B" & Em + 1 & "").Value = Application.Index(Dik1.items(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
Let Range("C2:H" & Em + 1 & "").Value = Application.Index(Dik2.items, Evaluate("=Row(1:" & Em & ")"), Array(1, 2, 3, 4, 5, 6)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
Range("A1:H1").EntireColumn.AutoFit
End Sub

[DocAElstein]

An extra macro for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=36401
post
https://eileenslounge.com/viewtopic.php?p=282498#p282498




Option Explicit
Sub AL1AL2__() '
Dim Ar As Long, Em As Long
Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 ' The main data from column 1
Dim AL1 As Object, AL2 As Object: Set AL1 = CreateObject("System.Collections.ArrayList"): Set AL2 = CreateObject("System.Collections.ArrayList")
For Ar = 1 To Em ' The main data rows range
AL1.Add Split(A(Ar, 1), " ", 2, vbBinaryCompare) ' I am splitting each data into 2 bits, the first is the data ID the second is all the rest
AL2.Add Split(StrReverse(AL1.Item(Ar - 1)(1)), " ", 6, vbBinaryCompare) ' We are splitting the reversed string, because my second data CITY might have a few words, I split the backward string in just enough bits so that the last element is the data CITY regardles of how many words are in it
Let AL2.Item(Ar - 1) = Array(StrReverse(AL2.Item(Ar - 1)(5)), StrReverse(AL2.Item(Ar - 1)(4)), StrReverse(AL2.Item(Ar - 1)(3)), StrReverse(AL2.Item(Ar - 1)(2)), StrReverse(AL2.Item(Ar - 1)(1)), StrReverse(AL2.Item(Ar - 1)(0))) ' The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
Next Ar
' The end result of the above is that we have two 1 D arrays in the Array Lists, one in each. Each element is itself a 1 D array. We find that strangely that INDEX seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the Index(arr(), Rws(), Clms()) way to get out our final range in any order we like.
Let Range("B2:B" & Em + 1 & "").Value = Application.Index(AL1.toarray(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
Let Range("C2:H" & Em + 1 & "").Value = Application.Index(AL2.toarray(), Evaluate("=Row(1:" & Em & ")"), Array(1, 2, 3, 4, 5, 6)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
Range("A1:H1").EntireColumn.AutoFit
End Sub

[DocAElstein]

Some extra notes for the solution to this Thread
https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes

This what C2 looks like
_____ Workbook: LisaExSampleFile.xlsm ( Using Excel 2007 32 bit )
Row\Col
C

2655; 661; 663; 665; 667; 6688; 670; 677; 678; 68860-68861; 68864; 68877; 6889; 689; 690; 810; 820
Worksheet: Old


"655" & ";" & " 661" & ";" & " 663" & ";" & " 665" & ";" & " 667" & ";" & " 6688" & ";" & " 670" & ";" & " 677" & ";" & " 678" & ";" & " 68860" & "-" & "68861" & ";" & " 68864" & ";" & " 68877" & ";" & " 6889" & ";" & " 689" & ";" & " 690" & ";" & " 810" & ";" & " 820"



"655" & ";" & " 661" & ";" & " 663" & ";" & " 665" & ";" & " 667" & ";" & " 6688" & ";" & " 670" & ";" & " 677" & ";" & " 678" & ";" & " 68860" & "-" & "68861" & ";" & " 68864" & ";" & " 68877" & ";" & " 6889" & ";" & " 689" & ";" & " 690" & ";" & " 810" & ";" & " 820"



' https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes
' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15531&viewfull=1#post15531
Sub AlexSaltColumnB()
Dim WsOld As Worksheet: Set WsOld = Workbooks("LisaExSampleFile.xlsm").Worksheets("Old")
Dim strC2 As String: Let strC2 = WsOld.Range("C2").Value2
' 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
' http://www.eileenslounge.com/viewtopic.php?f=30&t=35732&p=278061#p278061
' 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=15522&viewfull=1#post15522
' https://pastebin.com/HatYwAAD

Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strC2) ' A function of mine which i wrote. this analyses all characters in a given text string, in this case a cell in column C
End Sub
' "655" & ";" & " 661" & ";" & " 663" & ";" & " 665" & ";" & " 667" & ";" & " 6688" & ";" & " 670" & ";" & " 677" & ";" & " 678" & ";" & " 68860" & "-" & "68861" & ";" & " 68864" & ";" & " 68877" & ";" & " 6889" & ";" & " 689" & ";" & " 690" & ";" & " 810" & ";" & " 820"

[DocAElstein]

In support of this answer
https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15532#post15532

Old Worksheet:

_____ Workbook: Task.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGH
1NameNumberCodeNoteDateCurrencyMinMax

2John43655; 661; 663; 665; 667; 6688; 670; 677; 678; 68860-68861; 68864; 68877; 6889; 689; 690; 810; 82003-01-2021USD19.8324.79

3Steve43660; 67833; 67890; 67891; 68183; 69903-01-2021USD17.3821.73

4Tom436600; 699003-01-2021USD17.3821.73

5Anthony43644; 664; 680; 681; 688; 69981-69982; 69988-6998903-01-2021USD17.3821.73
Worksheet: Old


New worksheet , Before running macro

Row\ColABCDEFGHI
1NameNumberCodeNoteDateCurrencyMinMax

2
Worksheet: New

New worksheet After running Sub Alex1()

Row\ColABCDEFGH
1NameNumberCodeNoteDateCurrencyMinMax

2John4365503-01-2021USD19.8324.79

3John4366103-01-2021USD19.8324.79

4John4366303-01-2021USD19.8324.79

5John4366503-01-2021USD19.8324.79

6John4366703-01-2021USD19.8324.79

7John43668803-01-2021USD19.8324.79

8John4367003-01-2021USD19.8324.79

9John4367703-01-2021USD19.8324.79

10John4367803-01-2021USD19.8324.79

11John436886003-01-2021USD19.8324.79

12John436886103-01-2021USD19.8324.79

13John436886403-01-2021USD19.8324.79

14John436887703-01-2021USD19.8324.79

15John43688903-01-2021USD19.8324.79

16John4368903-01-2021USD19.8324.79

17John4369003-01-2021USD19.8324.79

18John4381003-01-2021USD19.8324.79

19John4382003-01-2021USD19.8324.79

20Steve4366003-01-2021USD17.3821.73

21Steve436783303-01-2021USD17.3821.73

22Steve436789003-01-2021USD17.3821.73

23Steve436789103-01-2021USD17.3821.73

24Steve436818303-01-2021USD17.3821.73

25Steve4369903-01-2021USD17.3821.73

26Tom43660003-01-2021USD17.3821.73

27Tom43699003-01-2021USD17.3821.73

28Anthony4364403-01-2021USD17.3821.73

29Anthony4366403-01-2021USD17.3821.73

30Anthony4368003-01-2021USD17.3821.73

31Anthony4368103-01-2021USD17.3821.73

32Anthony4368803-01-2021USD17.3821.73

33Anthony436998103-01-2021USD17.3821.73

34Anthony436998203-01-2021USD17.3821.73

35Anthony436998803-01-2021USD17.3821.73

36Anthony436998903-01-2021USD17.3821.73
Worksheet: New

[DocAElstein]

Some further tests in support of this Thread: https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes
this post: https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15539&viewfull=1#post15539

Some transpose tests using this test macro


Sub TransposyTests() ' https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15539&viewfull=1#post15539
Dim strTst As String
Let strTst = "068 069"
Dim arrOutTempC() As String '
Let arrOutTempC() = Split(strTst, " ", -1, vbBinaryCompare)
Dim arrOutTempCT1() As Variant, arrOutTempCT2() As Variant, arrOutTempCT3() As Variant
Let arrOutTempCT1() = Application.Index(arrOutTempC(), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")/row(1:" & UBound(arrOutTempC()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")"))
Let arrOutTempCT2() = Application.Transpose(arrOutTempC())
Dim Cnt: ReDim arrOutTempCT3(1 To 2, 1 To 1)
For Cnt = 0 To UBound(arrOutTempC())
Let arrOutTempCT3(Cnt + 1, 1) = arrOutTempC(Cnt)
Next Cnt
Stop
End Sub

Running that macro then stopping it before it ends, then highlighting the array variables followed by hitting Shift+F9 will reveal the contents in the Watch Window

http://i.imgur.com/ZZHD5qf.jpg
3575
https://i.imgur.com/ZZHD5qf.jpg

At first glance it looks like the transpose is not the problem

[DocAElstein]

Continued from last post

If you then look once again at array contents, then you still have what you want : For example in your test data for row with 18; 061-069, this here is what you see.
3576
http://i.imgur.com/jbwTQdl.jpg
https://i.imgur.com/jbwTQdl.jpg


Once again, the transpose is not the problem

[DocAElstein]

Another alternative solution for
https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15552&viewfull=1#post15552



Sub AlexAlanPascal() ' https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15549#post15549 https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15539&viewfull=1#post15539 https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes
Rem 1 Worksheets info
Dim WsOld As Worksheet, WsNew As Worksheet
Set WsOld = ThisWorkbook.Worksheets("Old"): Set WsNew = ThisWorkbook.Worksheets("New")
Dim Lr As Long: Let Lr = WsOld.Range("A" & WsOld.Rows.Count & "").End(xlUp).Row ' https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files-or-single-Excel-File?p=11467&viewfull=1#post11467
Rem 2
Dim ACel As Range, TLeft As Long: Let TLeft = 2 ' This variable holds the position of the next section in the New worksheet
For Each ACel In WsOld.Range("A2:A" & Lr & "") ' main loop going down all name cells ======
Dim AName As String: Let AName = ACel.Value2
Dim CVal As String: Let CVal = ACel.Offset(0, 2).Value2 & ";" ' I need the extra ; or otherwise I might miss the last number range ( number range is something like 45-48 ) if there is one, because I look for the ; in order to determine where that number rang ends
' 2b modifying any 3-5 type data
Dim PosDsh As Long: Let PosDsh = InStr(1, CVal, "-", vbBinaryCompare)
Do While PosDsh > 0 ' Position of the dash will be returned as 0 by the Instr function if the Instr function cannot find a next dash. Also my coding below might retun me -1 at this line ---###

Dim StrtN As String, StpN As String ' I use these variables initially for the position of the number and then the actual number
Let StrtN = InStrRev(Left(CVal, PosDsh), " ", -1, vbBinaryCompare) + 1
Let StrtN = Mid(CVal, StrtN, PosDsh - StrtN)
Let StpN = InStr(PosDsh, CVal, ";", vbBinaryCompare)
Let StpN = Mid(CVal, PosDsh + 1, (StpN - 1) - PosDsh)
Dim NRng As String

Let NRng = StrtN & "-" & StpN
Dim Cnt As Long, Padding As Long
Let Padding = Len(StrtN)
For Cnt = StrtN To StpN Step 1
Dim NRngMod As String
' Dim FrstSym As String
' Let FrstSym = Left(NRng, 1)
' If FrstSym = 0 Then
' Let NRngMod = NRngMod & "0" & Cnt & "; "
' Else
' Let NRngMod = NRngMod & Cnt & "; "
' End If
Let NRngMod = NRngMod & Format(Cnt, Application.Rept(0, Padding)) & "; "
Next Cnt
Let NRngMod = Left(NRngMod, Len(NRngMod) - 2) ' I don't need the last 2 characters of "; "
Let CVal = Replace(CVal, NRng, NRngMod & "|", 1, 1, vbBinaryCompare) ' I haver a temporary "|" to indicate the end of the last modified bit
Let PosDsh = InStr((InStr(1, CVal, "|", vbBinaryCompare)), CVal, "-", vbBinaryCompare) - 1 ' because I start looking at just after the last modified part, this will return me the position of the next one, ( or 0 if none is found ) -1 is because I am reducing the length by 1 in the next code line ---###
Let CVal = Replace(CVal, "|", "", 1, 1, vbBinaryCompare)

Let NRngMod = "" ' rest this variable for next use '
Loop

' 2c Modified column C output
Let CVal = Replace(CVal, ";", "", 1, -1, vbBinaryCompare) ' I don't want any ; in the modified list
Dim arrOutTempC() As String '
Let arrOutTempC() = Split(CVal, " ", -1, vbBinaryCompare)
Dim arrOutTempCT() As Variant
Let arrOutTempCT() = Application.Index(arrOutTempC(), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")/row(1:" & UBound(arrOutTempC()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")"))
' 2d All New column output
Let WsNew.Range("C" & TLeft & ":C" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = arrOutTempCT()
Let WsNew.Range("A" & TLeft & ":A" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Value2 ' Name
Let WsNew.Range("B" & TLeft & ":B" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 1).Value2 ' Number
Let WsNew.Range("E" & TLeft & ":E" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 4).Value2 ' Date
Let WsNew.Range("E" & TLeft & ":E" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").NumberFormat = "m/d/yyyy"
Let WsNew.Range("F" & TLeft & ":F" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 5).Value2 ' Currency
Let WsNew.Range("G" & TLeft & ":G" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 6).Value2 ' Min
Let WsNew.Range("H" & TLeft & ":H" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 7).Value2 ' Max

Let TLeft = TLeft + UBound(arrOutTempCT(), 1) ' this should adjust our top left cell for next range of new columns
Next ACel ' ' main loop going down all name cells =========

End Sub

[DocAElstein]

In support of this Thread
https://excelfox.com/forum/showthread.php/2756-How-to-calculate-best-bowling-figure-(cricket)

_____ Workbook: Stats_Template.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLM
1Player 1OversMaidenRunsWicketsBwl AveEconWidesNo Ballsballsstrike rate5wBBI

2Match 1111.00n/a00.00

3Match 2111.00n/a00.00

4Match 3120.50n/a00.00

5Match 4120.50n/a00.00

6Match 570323.33n/a00.00

7Match 6111.00n/a00.00

8Match 7111.00n/a00.00

9Match 8111.00n/a00.00

10Match 932310.67n/a00.00

11Match 10111.00n/a00.00

12Match 11111.00n/a00.00

13Match 12111.00n/a00.00

14Match 13111.00n/a00.00

15Match 14111.00n/a00.00

16Match 15111.00n/a00.00

17Match 16111.00n/a00.00

18Match 17111.00n/a00.00

19Match 18111.00n/a00.00

20Match 19111.00n/a00.00

21Match 20111.00n/a00.00

22Player 100120264.620.000000.000

23

24Player 2OversMaidenRunsWicketsBwl AveEconWidesNo Ballsballsstrike rate5w

25Match 1n/an/a0n/a

26Match 2n/an/a0n/a
Worksheet: Sheet3



A basic formula to get a maximum value:

_____ Workbook: Stats_Template.xls ( Using Excel 2007 32 bit )
Row\Col
N

8MxD


9
3
Worksheet: Sheet3

_____ Workbook: Stats_Template.xls ( Using Excel 2007 32 bit )
Row\Col
N

8MxD


9
=MAX(E2:E21)
Worksheet: Sheet3

[DocAElstein]

.... test post for later

Hi prkhan56
Welcome to ExcelFox

I am sorry you have had no reply.
We don’ t have many Word experts popping by excelfox much these days.

I don’t know much about Word VBA, and have never done anything with images so I don’t really understand what is wanted here. I don’t see the relation to images , pictures , “moving images”.

I have manipulated Word files with some VBA code working from Excel. Sometime my files were saved as extension type .htm – those files were normal word files with a lot of text and tables in them and the coding handled them the same as any files of extension type .doc or .docx or .docm

So I am not really so well qualified to help on what you want, but I will have a go…..



I took a quick look at this macro , Sub GetPicturesFromWordDocument() ,
I have rewritten, or rather just re arranged slightly the macro and made some minor changes as I went along and added some 'comments . I did this to help me understand what is going on.
( Here is my version: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15614&viewfull=1#post15614 )

Here is a walk through my version:
For the sake of explanation, let me assume that when you run this macro you have a Word document open , which is active, and it has the name MyDoc.doc

The macro stores the current active document name ( but without the extension type) in strDocumentName. So if the active document was MyDoc.doc , then strDocumentName will have MyDoc in it.
We also store the path to the current active document in strPath
The macro seems to save the active document under its existing name, at the existing place, but with the extension type changed to .htm , so you would have then the active document, if it was MyDoc.doc now saved as MyDoc.htm - …. It is not clear to me why that is being done??

The macro makes a folder, MovedToHere in the same place as where the current active document is. I have slightly modified this code line, to prevent it erroring if the folder already exists: It only makes the folder if the folder does not exist. - If you try to make a folder when it already exists, then that would chuck up an error

__ The main outer loop === is doing the following:
It is looping 4 times, going through all your file extension types, .png .jpeg .jpg and .bmp. ( The loop control variable, lngLoop , is going from 0 To 3 )
__ For each file extension type it is looking for files which are in a folder which, using the same example, would have a name like MyDoc_files . That folder is looked for at the same path as the current active document.
So for example, the first loop is looking for files of the extension type .png in that folder
____ The purpose of the Do While __ Loop _ loop is to keep going while you still find files of the extension type currently being looked for. ( The use of Dir on its own, without any bracket ( ) stuff tells VBA to look again for the next file of the same type and in the same place that it looked the last time )
____ Each of the files you find gets copied to folder, MovedToHere and has its name modified a bit to have the text "New " added at the start, like for example, Filex.png would become New Filex.png ( Note: actually we are not really copying – we are moving – the original file gets effectively deleted )

Once we have finished doing all that copying, we close the current active document. It is not clear to me why that is being done. In particular it’s not clear to me why it is done at this point. We could have closed it immediately after we created it, since we have done nothing with it since creating it

We now open the original file we had open at the start of running the macro. Its not clear to me why we do that, other than maybe to get back to having the same file open and active that we had when we started running the macro.

Now we go on to killing ( deleting ) a few things.
The code line Kill strPath & "" & strDocumentName & ".htm*" does not error for me. I can not see why it should, since it is trying to delete all files of the extension type .htm , html etc. in the folder where we made like our MyDoc.htm
Since we should have at least that one file there, MyDoc.htm , then that at least that is there to be deleted
The next code line, Kill strPath & "" & strDocumentName & "_files\*.*" could error , if, for example, you had only had files of the type .png .jpeg .jpg or .bmp originally in that folder with the name like MyDoc_files . The reason for that is because the VBA Name statement renames a file, in other words it moves , or in other words it copies the file to somewhere and then deletes the original. So effectively it will be removing all files of the type .png .jpeg .jpg or .bmp from that folder.
So I have modified that code line so that it only tries to delete files if there are any files there to delete.
I expect the reason the code line is there is so that the next code line works. – This next code line, RmDir strPath & "" & strDocumentName & "_files" , tries to delete the original folder, and that code line would error if any files were in that folder.

The last few lines are not needed in VBA. Those code lines were considered good practice in programming earlier, I think. Possibly they may have sometimes been needed previously. I am not sure.

I am not sure if I can help much further, since I cannot reproduce your error. The macro version of mine ( Here: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15614&viewfull=1#post15614 ) does not error, but I may have missed something due to my lack of experience with Word VBA.

I want to fix this code ...... Can someone fix this issue ...
I cant fix the code for you , because I cannot see the problem with it. But I am also not 100% sure of why some things are being done in the macro.




.....and also amend to run on all the sub folders..... I don’t think you can amend a macro like this one to do that. The reason for me saying that is that the main process we are using to look at, and get at files, is the Dir function, and in particular the code line of Dir within a loop. This restricts us to one “folder level”.
We are using a fairly simple macro, like the one you are using.
Its this sort of thing: https://excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=6175&viewfull=1#post6175
To look at sub folders we would usually use a different macro type, one which uses recursion. This sort of thing:
https://excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=10420&viewfull=1#post10420
https://excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=10421&viewfull=1#post10421
https://excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=10422&viewfull=1#post10422

As you can see, that is a rather complex thing. Depending on your knowledge of VBA, that could be a rather time consuming thing to get across to you, especially as we don’t have the simpler issue fixed of why you are getting the error in the simpler macro

I expect it could take me a long time to help you further. I am busy all this week, and could take another look for you next week.

Alternatively you might want to try one of the other forums where a lot more people usually are, and certainly more people clued up on Word VBA
Here a couple of places :
https://www.excelforum.com/word-programming-vba-macros/
http://www.eileenslounge.com/viewforum.php?f=26

Please note that most forums have what they call a “cross posting rule”. This means that you should tell everyone everywhere about where else you have posted the same question.
So for example you should pass on these URL link to your questions here
https://excelfox.com/forum/showthread.php/2760-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15605#post15605
https://excelfox.com/forum/showthread.php/2761-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15613#post15613
One last tip here: If you are posting for the first time at some forums then a spam filter will prevent you posting those links. To get over that you need to disguise them when posting. You could add some spaces like this
h t t p s:/ /excelfox . com/forum/showthread.php/2760-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15605#post15605
h t t p s:/ /excelfox . com/forum/showthread.php/2761-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15613#post15613
Or alternatively try fooling the filter by posting using some BB code for black color to disguise the link – that way the filter does not see the link, but it comes out in the final post as you want it
https://excelfox.com/forum/showthread.php/2760-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15605#post15605
https://excelfox.com/forum/showthread.php/2761-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15613#post15613


Alan

[DocAElstein]

testing image links

Hallo Seit dem letzten Mal habe ich viele Male versucht... Auch habe ich es in einem anderen Drucker versucht. Außerdem habe ich weitere Patronen gekauft.
Die meisten Patronen funktionieren die meiste Zeit in allen Druckern, abgesehen von Ihren 2 Patronen, die immer noch in keinem Drucker funktionieren...
_.. <stellen Sie sicher..die schwarze Abdeckung entfernt wurde, bevor Sie die Tinte installieren….. Wischen Sie die Chips und den Kontaktpunkt …> . - Ja, ich kenne das alles schon sehr gut und habe es schon oft versucht
_..<.. Bersetzen Sie durch Ihre eigene Patrone, ob Problem verschwindet …> .. - Ja, ich habe viele meiner Patronen ausprobiert und das Problem ist dann immer verschwunden
_...< Fotos der auf Ihrem Drucker angezeigten Fehlermeldung…> rote lichter zeigen immer - http://i.imgur.com/p04geAd.jpg
_..< .. Foto zeigt Ihr Druckermodell ..> ich habe 2 http://i.imgur.com/6pR66Gk.jpg . Eins benutze ich viel, http://i.imgur.com/k8ldcax.jpg , das andere ist eine Reserve und wird nicht viel verwendet , http://i.imgur.com/SsIaPZN.jpg
Ich habe auch mit dem meiner Frau experimentiert , http://i.imgur.com/3D9GVBt.jpg
ALLE SIND DAS GLEICHE MODELL HP Deskjet 1050A - http://i.imgur.com/DigfVU5.jpg
_..<.. Wie viele Tintenpatronen haben Sie ausprobiert .. welche haben nicht funktioniert? ..> - Ich habe 6 meiner Patronen ausprobiert. Die Patronen stammen aus 3 verschiedenen Quellen:-
_ Ich habe neu im lokalen Geschäft gekauft - http://i.imgur.com/2js4bjY.jpg
_ Ich habe neu im Internet - http://i.imgur.com/Ln6DkAG.jpg
_ Ich habe auch zwei von einem kaputten Drucker - http://i.imgur.com/YwqulO8.jpg , http://i.imgur.com/BdRbG1W.jpg , http://i.imgur.com/MnTGALx.jpg

Also habe ich 6 verschiedene Patronen von mir ausprobiert. (Alle sind original HP http://i.imgur.com/x8IYpp4.jpg , http://i.imgur.com/lxjGZqq.jpg , http://i.imgur.com/xhF5tnO.jpg , http://i.imgur.com/9G9HuUt.jpg , http://i.imgur.com/MnTGALx.jpg ). - Alle funktionieren die meiste Zeit in allen meinen Druckern, - http://i.imgur.com/YOFWpT1.jpg , http://i.imgur.com/xJL04SQ.jpg , http://i.imgur.com/sL0VbdT.jpg , http://i.imgur.com/WvrC9D3.jpg

Die Patronen von Ihnen funktionieren immer noch in keinem meiner Drucker - http://i.imgur.com/p04geAd.jpg

Alan

Hallo Seit dem letzten Mal habe ich viele Male versucht... Auch habe ich es in einem anderen Drucker versucht. Außerdem habe ich weitere Patronen gekauft.
Die meisten Patronen funktionieren die meiste Zeit in allen Druckern, abgesehen von Ihren 2 Patronen, die immer noch in keinem Drucker funktionieren...
_..<stellen Sie sicher..die schwarze Abdeckung entfernt wurde, bevor Sie die Tinte installieren….. Wischen Sie die Chips und den Kontaktpunkt …> . - Ja, ich kenne das alles schon sehr gut und habe es schon oft versucht
_..<.. Bersetzen Sie durch Ihre eigene Patrone, ob Problem verschwindet …> .. - Ja, ich habe viele meiner Patronen ausprobiert und das Problem ist dann immer verschwunden
_...< Fotos der auf Ihrem Drucker angezeigten Fehlermeldung…> rote lichter zeigen immer - http://i.imgur.com/p04geAd.jpg
_..< .. Foto zeigt Ihr Druckermodell ..> ich habe 2 http://i.imgur.com/6pR66Gk.jpg . Eins benutze ich viel, http://i.imgur.com/k8ldcax.jpg , das andere ist eine Reserve und wird nicht viel verwendet , http://i.imgur.com/SsIaPZN.jpg
Ich habe auch mit dem meiner Frau experimentiert , http://i.imgur.com/3D9GVBt.jpg
ALLE SIND DAS GLEICHE MODELL HP Deskjet 1050A - http://i.imgur.com/DigfVU5.jpg
_..<.. Wie viele Tintenpatronen haben Sie ausprobiert .. welche haben nicht funktioniert? ..> - Ich habe 6 meiner Patronen ausprobiert. Die Patronen stammen aus 3 verschiedenen Quellen:-
_ Ich habe neu im lokalen Geschäft gekauft - http://i.imgur.com/2js4bjY.jpg
_ Ich habe neu im Internet - http://i.imgur.com/Ln6DkAG.jpg
_ Ich habe auch zwei von einem kaputten Drucker - http://i.imgur.com/YwqulO8.jpg , http://i.imgur.com/BdRbG1W.jpg , http://i.imgur.com/MnTGALx.jpg

Also habe ich 6 verschiedene Patronen von mir ausprobiert. (Alle sind original HP http://i.imgur.com/x8IYpp4.jpg , http://i.imgur.com/lxjGZqq.jpg , http://i.imgur.com/xhF5tnO.jpg , http://i.imgur.com/9G9HuUt.jpg , http://i.imgur.com/MnTGALx.jpg ). - Alle funktionieren die meiste Zeit in allen meinen Druckern, - http://i.imgur.com/YOFWpT1.jpg , http://i.imgur.com/xJL04SQ.jpg , http://i.imgur.com/sL0VbdT.jpg , http://i.imgur.com/WvrC9D3.jpg

Die Patronen von Ihnen funktionieren immer noch in keinem meiner Drucker - http://i.imgur.com/p04geAd.jpg

Alan

Hallo Seit dem letzten Mal habe ich viele Male versucht... Auch habe ich es in einem anderen Drucker versucht. Außerdem habe ich weitere Patronen gekauft.
Die meisten Patronen funktionieren die meiste Zeit in allen Druckern, abgesehen von Ihren 2 Patronen, die immer noch in keinem Drucker funktionieren...
_.. < stellen Sie sicher..die schwarze Abdeckung entfernt wurde, bevor Sie die Tinte installieren….. Wischen Sie die Chips und den Kontaktpunkt …> . - Ja, ich kenne das alles schon sehr gut und habe es schon oft versucht
_..<.. Bersetzen Sie durch Ihre eigene Patrone, ob Problem verschwindet …> .. - Ja, ich habe viele meiner Patronen ausprobiert und das Problem ist dann immer verschwunden
_...< Fotos der auf Ihrem Drucker angezeigten Fehlermeldung…> rote lichter zeigen immer - http://i.imgur.com/p04geAd.jpg
_..< .. Foto zeigt Ihr Druckermodell ..> ich habe 2 http://i.imgur.com/6pR66Gk.jpg . Eins benutze ich viel, http://i.imgur.com/k8ldcax.jpg , das andere ist eine Reserve und wird nicht viel verwendet , http://i.imgur.com/SsIaPZN.jpg
Ich habe auch mit dem meiner Frau experimentiert , http://i.imgur.com/3D9GVBt.jpg
ALLE SIND DAS GLEICHE MODELL HP Deskjet 1050A - http://i.imgur.com/DigfVU5.jpg
_..<.. Wie viele Tintenpatronen haben Sie ausprobiert .. welche haben nicht funktioniert? ..> - Ich habe 6 meiner Patronen ausprobiert. Die Patronen stammen aus 3 verschiedenen Quellen:-
_ Ich habe neu im lokalen Geschäft gekauft - http://i.imgur.com/2js4bjY.jpg
_ Ich habe neu im Internet - http://i.imgur.com/Ln6DkAG.jpg
_ Ich habe auch zwei von einem kaputten Drucker - http://i.imgur.com/YwqulO8.jpg , http://i.imgur.com/BdRbG1W.jpg , http://i.imgur.com/MnTGALx.jpg

Also habe ich 6 verschiedene Patronen von mir ausprobiert. (Alle sind original HP http://i.imgur.com/x8IYpp4.jpg , http://i.imgur.com/lxjGZqq.jpg , http://i.imgur.com/xhF5tnO.jpg , http://i.imgur.com/9G9HuUt.jpg , http://i.imgur.com/MnTGALx.jpg ). - Alle funktionieren die meiste Zeit in allen meinen Druckern, - http://i.imgur.com/YOFWpT1.jpg , http://i.imgur.com/xJL04SQ.jpg , http://i.imgur.com/sL0VbdT.jpg , http://i.imgur.com/WvrC9D3.jpg

Die Patronen von Ihnen funktionieren immer noch in keinem meiner Drucker - http://i.imgur.com/p04geAd.jpg

Alan

Hallo
Seit dem letzten Mal habe ich viele Male versucht... Auch habe ich es in einem anderen Drucker versucht. Außerdem habe ich weitere Patronen gekauft.
Die meisten Patronen funktionieren die meiste Zeit in allen Druckern, abgesehen von Ihren 2 Patronen, die immer noch in keinem Drucker funktionieren...
_.. < stellen Sie sicher..die schwarze Abdeckung entfernt wurde, bevor Sie die Tinte installieren….. Wischen Sie die Chips und den Kontaktpunkt …> . - Ja, ich kenne das alles schon sehr gut und habe es schon oft versucht
_..<.. Bersetzen Sie durch Ihre eigene Patrone, ob Problem verschwindet …> .. - Ja, ich habe viele meiner Patronen ausprobiert und das Problem ist dann immer verschwunden
_...< Fotos der auf Ihrem Drucker angezeigten Fehlermeldung…> - rote lichter zeigen immer - http://i.imgur.com/p04geAd.jpg
_..< .. Foto zeigt Ihr Druckermodell ..> ich habe 2 http://i.imgur.com/6pR66Gk.jpg . Eins benutze ich viel, http://i.imgur.com/k8ldcax.jpg , das andere ist eine Reserve und wird nicht viel verwendet , http://i.imgur.com/SsIaPZN.jpg
Ich habe auch mit dem meiner Frau experimentiert , http://i.imgur.com/3D9GVBt.jpg
ALLE SIND DAS GLEICHE MODELL HP Deskjet 1050A - http://i.imgur.com/DigfVU5.jpg
_..<.. Wie viele Tintenpatronen haben Sie ausprobiert .. welche haben nicht funktioniert? ..> - Ich habe 6 meiner Patronen ausprobiert. Die Patronen stammen aus 3 verschiedenen Quellen:-
_ Ich habe neu im lokalen Geschäft gekauft - http://i.imgur.com/2js4bjY.jpg
_ Ich habe neu im Internet - http://i.imgur.com/Ln6DkAG.jpg
_ Ich habe auch zwei von einem kaputten Drucker - http://i.imgur.com/YwqulO8.jpg , http://i.imgur.com/BdRbG1W.jpg , http://i.imgur.com/MnTGALx.jpg

Also habe ich 6 verschiedene Patronen von mir ausprobiert. (Alle sind original HP http://i.imgur.com/x8IYpp4.jpg , http://i.imgur.com/lxjGZqq.jpg , http://i.imgur.com/xhF5tnO.jpg , http://i.imgur.com/9G9HuUt.jpg , http://i.imgur.com/MnTGALx.jpg ). - Alle funktionieren die meiste Zeit in allen meinen Druckern, - http://i.imgur.com/YOFWpT1.jpg , http://i.imgur.com/xJL04SQ.jpg , http://i.imgur.com/sL0VbdT.jpg , http://i.imgur.com/WvrC9D3.jpg

Die Patronen von Ihnen (http://i.imgur.com/NwM9JBg.jpg , http://i.imgur.com/byeNd0X.jpg ) funktionieren immer noch in keinem meiner Drucker - http://i.imgur.com/p04geAd.jpg

Alan

https://i.postimg.cc/wxsdHN33/CodeTags.jpg

[DocAElstein]

In support of these forum Threads:
https://excelfox.com/forum/showthread.php/2760-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15605#post15605
https://excelfox.com/forum/showthread.php/2761-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15613#post15613



Sub GetPicturesFromWordDocument() ' https://excelfox.com/forum/showthread.php/2760-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15605#post15605 https://excelfox.com/forum/showthread.php/2761-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15613#post15613
Dim strFile As String, strFileType As String, strPath As String, strOriginalFile As String, strDocumentName As String
Dim lngLoop As Long
Let strFileType = "*.png;*.jpeg;*.jpg;*.bmp" 'Split with semi-colon if you want to specify more file types

Let strOriginalFile = ActiveDocument.FullName
Let strDocumentName = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) ' The macro stores the current active document name ( but without the extension type) in strDocumentName. So if the active document was MyDoc.doc , then strDocumentName will have MyDoc in it.
Let strPath = ActiveDocument.Path ' We also store the path to the current active document in strPath

ActiveDocument.SaveAs strPath & "\" & strDocumentName, wdFormatHTML, , , , , True ' The macro seems to save the active document under its existing name, at the existing place, but with the extension type changed to .htm , so you would have then the active document, if it was MyDoc.doc now saved as MyDoc.htm - …. It is not clear to me why that is being done??

If Dir(strPath & "\MovedToHere", vbDirectory) = "" Then MkDir strPath & "\MovedToHere" ' The macro makes a folder, MovedToHere in the same place as where the current active document is. I have slightly modified this code line, to prevent it erroring if the folder already exists: It only makes the folder if the folder does not exist. - If you try to make a folder when it already exists, then that would chuck up an error

For lngLoop = LBound(Split(strFileType, ";")) To UBound(Split(strFileType, ";")) ' ======================== The main outer loop is doing the following: It is looping 4 times, going through all your file extension types, .png .jpeg .jpg and .bmp. ( The loop control variable, lngLoop , is going from 0 To 3 ) For each file extension type it is looking for files which are in a folder which, using the same example, would have a name like MyDoc_files . That folder is looked for at the same path as the current active document.So for example, the first loop is looking for files of the extension type .png in that folder
Let strFile = Dir(strPath & "\" & strDocumentName & "_files\" & Split(strFileType, ";")(lngLoop))
Do While strFile <> "" ' The purpose of the Do While __ Loop _ loop is to keep going while you still find files of the extension type currently being looked for.
Name strPath & "\" & strDocumentName & "_files\" & strFile As strPath & "\MovedToHere\" & "New " & strFile ' Each of the files you find gets copied to folder, MovedToHere and has its name modified a bit to have the text "New " added at the start, like for example, Filex.png would become New Filex.png
Let strFile = Dir ' The use of Dir on its own, without any bracket ( ) stuff tells VBA to look again for the next file of the same type and in the same place that it looked the last time
Loop
Next lngLoop ' ================================================== ==========================================

ActiveDocument.Close 0 ' Once we have finished doing all that copying, we close the current active document. It is not clear to me why that is being done. In particular it’s not clear to me why it is done at this point. We could have closed it immediately after we created it, since we have done nothing with it since creating it
Documents.Open strOriginalFile ' We now open the original file we had open at the start of running the macro. Its not clear to me why we do that, other than maybe to get back to having the same file open and active that we had when we started running the macro.

Kill strPath & "\" & strDocumentName & ".htm*"
If Not Dir(strPath & "\" & strDocumentName & "_files\*.*") = "" Then Kill strPath & "\" & strDocumentName & "_files\*.*" ' Kill strPath & "" & strDocumentName & "_files\*.*" could error , if, for example, you had only had files of the type .png .jpeg .jpg or .bmp originally in that folder with the name like MyDoc_files . The reason for that is because the VBA Name statement renames a file, in other words it moves , or in other words it copies the file to somewhere and then deletes the original. So effectively it will be removing all files of the type .png .jpeg .jpg or .bmp from that folder. So I have modified that code line so that it only tries to delete files if there are any files there to delete. I expect the reason the code line is there is so that the next code line works. – This next code line, RmDir strPath & "" & strDocumentName & "_files" , tries to delete the original folder, and that code line would error if any files were in that folder.
RmDir strPath & "\" & strDocumentName & "_files" ' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/rmdir-statement
'strFile = vbNullString ' These last few lines are not needed in VBA. These code lines were considered good practice in programming earlier, I think. Possibly they may have sometimes been needed previously. I am not sure.
'strFileType = vbNullString
'strPath = vbNullString
'lngLoop = Empty

End Sub

[DocAElstein]

Some extra notes in support of this Thread post:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630
Einige zusätzliche Hinweise zur Unterstützung dieses Thread-Beitrags:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630


Anfangs, als Laie, dachte ich, dass eine Fritzbox keine Zugangsdaten braucht. Das war falsche. Aber hier erkläre ich warum ich das gedacht haben:


Diese Screenshots zeigen einen typischen automatisierten Prozess, der beim ersten Anschließen eines neuen FRITZ!Box 7590 Routers startet
https://i.postimg.cc/vTJ9T8b9/FRITZ-Box-7590-First-use.jpg
https://i.postimg.cc/hGcLVGx1/FRITZ-Box-7590-First-use.jpg
https://i.postimg.cc/gjX8GLFm/FRITZ-Box-7590-First-use.jpg
https://i.postimg.cc/fbCxChfn/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/wTRQpZgL/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/rs3G4CCD/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/6QfhPZwP/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/MpkbK5p4/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/SsQGbKxx/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/4NYB3nbK/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/3Jz907nt/FRITZ-Box-7590-First-use-Nem-Empholung.jpg



und die letzten leeren Zugangsdatenfelder auch nach Neustarts leer bleiben.
https://i.postimg.cc/66jMwCRJ/After-FRITZ-Box-7590-First-second-use-Nem-Empholung-nor-zugang-date-shown-but-all-works.jpg


Aber der Router funktioniert, um Ihnen Internet zur Verfügung zu stellen, daher gehe ich davon aus, dass die verwendeten Zugangsdaten irgendwo innerhalb der Router an einem Ort gespeichert sind, auf den Sie keinen Zugriff haben.


(Wenn Sie später Zugangsdaten manuell hinzufügen, werden die intern gespeicherten Zugangsdaten mit Ihren Eingaben überschrieben und Ihre Eingaben werden in diesen letzten Feldern später immer angezeigt.)
https://i.postimg.cc/Hn2Xm6mM/FRITZ-Box-7590-Manual-Give-Zugansdaten.jpg
https://i.postimg.cc/prTX9C8z/FRITZ-Box-7590-After-Manual-Give-Zugansdaten-can-see-all-but-Persoenliches-Kennwort.jpg




Anfangs dachte ich fälschlicherweise, dass eine Fritzbox keine Zugangsdaten braucht.