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

Continued from last post ( https://excelfox.com/forum/showthrea...ll=1#post19863 )

Explanation of the two Match bits

Rem 1
Code:
Rem 1 try to match the name & Activity & Sub-activity
Dim arrD1() As Variant: Let arrD1() = WsD1.Evaluate("=A1:A25 & B1:B25 & C1:C25") ' This is a convenient way to get an array of the three things for all rows
Dim strSrch As String ': Let strSrch = Range("E2").Value & Range("F2").Value & Range("G2").Value ' This gives for example, "JohnA.1A.1.1"
Dim TgRw As Long: Let TgRw = Target.Row ' the changed target row
Let strSrch = Range("E" & TgRw & "").Value & Range("F" & TgRw & "").Value & Range("G" & TgRw & "").Value
Dim MtchRw As Long
Let MtchRw = Application.Match(strSrch, arrD1(), 0) ' this tries to match the correct row in Database1
This is fairly straight forward.
This is the array of name & Activity & Sub-activity

arrD1() =
NameActivitySub-activity
JohnA.1A.1.1
JohnA.1A.1.2
JohnA.2A.2.1
JohnA.2A.2.2
JohnA.3A.3.1
JohnA.3A.3.2
JohnA.4A.4.1
JohnA.4A.4.2
MarkA.1A.1.1
MarkA.1A.1.2
MarkA.2A.2.1
MarkA.2A.2.2
MarkA.3A.3.1
MarkA.3A.3.2
MarkA.4A.4.1
MarkA.4A.4.2
AnneA.1A.1.1
AnneA.1A.1.2
AnneA.2A.2.1
AnneA.2A.2.2
AnneA.3A.3.1
AnneA.3A.3.2
AnneA.4A.4.1
AnneA.4A.4.2


Now take for example the case of row 2 from worksheet database. I am looking to match this
JohnA.1A.1.1

So that is obviously 2 – ( Match tells me the position along in the array that it finds what it is looking for, the second position in this case is where it finds JohnA.1A.1.1 )



Rem 2 This is more tricky, and may not always work with different data. This initial solution may need to be re thought

This is the array of dates
arrDts() =
Name Activity Sub-activity 44866 44896 44927 44958 44986 45017 45047 45078

Now take for example from row 2, the date 30 November, 2022. Excel holds dates internally as numbers, and for the date 30 November, 2022 it has 44895.
I don’t have the number 44895 in my array. So this, Application.Match(DteV2, arrDts(), 0) , would give an error. It errors because it cannot find an exact match.

However we can use a 1 or -1 instead of the 0 in that final third argument in the Match - The syntax supports 3 different options, -1 0 1

If we choose 1 or -1 , then it will not error if it finds something close to what its looking for. The exact rules governing how that works are not so clear. I have a feeling Microsoft have some inconstant documentation in this.
For the case of using a 1 , we must have the numbers in the array in ascending order, which we have in the test data. I think then it tries to find the nearest smallest number.

Simple example to clarify:
In other words, if as a simple example, we had a 4 and a 9, in an array like this
{ 2 3 4 9 }
but we were lookig for a 8, then it would think that the matched value was 4, if we used a third argument of 1 in Match . So it would return us a 3 in that case as 4 is in position 3 along in the array.
In other words the 4 is the third number and its the nearest number to 8 that is smaller than 8. The number 9 is nearer, but that is a bigger number. (If we wanted that number 9 to get matched to 8, then I think the array must be in decending order, and we must use a -1 as the third argument in the Match


So...
Lets look again in detail at the test data and add some color highlighting to demo the results i get, which luckily are correct with the test data

The array: ( from Database1)
1
2
3
4
5
6
7
8
9
10
11
Name Activity Sub-activity
44866
44896
44927
44958
44986
45017
45047
45078


The 4 numbers I use from column D (from Database ) to get the results I want
44895
44895
44926
44985



If you follow the logic you can see that we will get the correct column numbers we want with the test data: We will get
4 4 5 7

But there are at least 3 issues to consider:

_1) This is relying on the date in column D in database being typically bigger than the corresponding date to be matched in Database1

_2) I am not sure how the Match always reacts to having a mixture of numbers and text in the array. It does not seem to cause a problem with the test data.

_3) The dates in Database1 must be typically in acending order. (I expect they probably willl be?)











( I added some extra stuff in the Database worksheet on the uploaded file to help show things a bit better )

https://i.postimg.cc/bNWqMYqT/1.jpg

https://i.postimg.cc/28Vz2LNy/2.jpg

https://i.postimg.cc/8kypRB3x/3.jpg



https://postimg.cc/TKSXsXV3

Some extra notes in support of this Thread post
https://excelfox.com/forum/showthrea...ll=1#post19860

I am using Match in two few places, and that is the main workings of the macro
Rem 1 - one gets the row number need for the output
Rem 2 – the other gets the column needed for the output

This is the test data given:





This is the requirement

Quote:

---

Originally Posted by Atlantis764

.....
- the value from H2 cell (Database) to be added in D2 cell (Database1) because the name is John, the Activity is A.1, Sub-activity is A.1.1 and the Month is November 2022 (with yellow)
- the value from H5 cell (Database) to be added in G20 cell (Database1) because the name is Anne, the Activity is A.2, Sub-activity is A.2.1 and the Month is February 2023 (with gray)
.......and so on

---

Next post, some further explanations , in particular about what the Match bits are about

Simple example to clarify:

Continued from last post ( https://excelfox.com/forum/showthrea...ll=1#post19863
https://www.excelfox.com/forum/showt...ll=1#post21921 )

Explanation of the two Match bits

Rem 1

Code:

---

Rem 1 try to match the  name & Activity & Sub-activity
Dim arrD1() As Variant: Let arrD1() = WsD1.Evaluate("=A1:A25 & B1:B25 & C1:C25") ' This is a convenient way to get an array of the three things for all rows
Dim strSrch As String ': Let strSrch = Range("E2").Value & Range("F2").Value & Range("G2").Value ' This gives for example,  "JohnA.1A.1.1"
Dim TgRw As Long: Let TgRw = Target.Row ' the changed target row
 Let strSrch = Range("E" & TgRw & "").Value & Range("F" & TgRw & "").Value & Range("G" & TgRw & "").Value
Dim MtchRw As Long
 Let MtchRw = Application.Match(strSrch, arrD1(), 0) ' this tries to match the correct row in Database1


---

This is fairly straight forward.
This is the array of name & Activity & Sub-activity

arrD1() =
NameActivitySub-activity
JohnA.1A.1.1
JohnA.1A.1.2
JohnA.2A.2.1
JohnA.2A.2.2
JohnA.3A.3.1
JohnA.3A.3.2
JohnA.4A.4.1
JohnA.4A.4.2
MarkA.1A.1.1
MarkA.1A.1.2
MarkA.2A.2.1
MarkA.2A.2.2
MarkA.3A.3.1
MarkA.3A.3.2
MarkA.4A.4.1
MarkA.4A.4.2
AnneA.1A.1.1
AnneA.1A.1.2
AnneA.2A.2.1
AnneA.2A.2.2
AnneA.3A.3.1
AnneA.3A.3.2
AnneA.4A.4.1
AnneA.4A.4.2


Now take for example the case of row 2 from worksheet database. I am looking to match this
John A.1 A.1.1

So that is obviously 2 – ( Match tells me the position along in the array that it finds what it is looking for, the second position in this case )

---

Rem 2 This is more tricky, and may not always work with different data. This initial solution may need to be re thought

This is the array of dates
arrDts() =
Name Activity Sub-activity 01-Nov-2022 44896 44927 44958 44986 45017 45047 45078

Now take for example from row 2, the date 30 November, 2022. Excel holds dates internally as numbers, and for the date 30 November, 2022 it has 44895.
I don’t have the number 44895 in my array. So this, Application.Match(DteV2, arrDts(), 0) , would give an error. It errors because it cannot find an exact match.

However we can use a 1 or -1 instead of the 0
If we do that it will not error if it finds something close to what its looking for. The exact rules governing how that works are not so clear. I have a feeling Microsoft have some inconstant documentation in this.
For the case of using a 1 , we must have the numbers its looking for in ascending order, which we have in the test data. I think then it tries to find the next smallest number.

Lets look again in detail at the test data and add some color highlighting to demo that

The array: ( from Database1)

1	2	3	4	5	6	7	8	9	10	11
Name	Activity	Sub-activity	44866	44896	44927	44958	44986	45017	45047	45078

The 4 numbers I use from column D (from Database ) to get the results I want

44895

44895

44926

44985

If you follow the logic you can see that we will get the correct column numbers we want with the test data: We will get
4 4 5 7

But there are at least two issues to consider:

_1) This is relying on the date in column D in database being typically bigger than the corresponding date to be matched in Database1

_2) I am not sure how the Match always reacts to having a mixture of numbers and text in the array. It does not seem to cause a problem with the test data.

Second solution, Solution 2 for this thread
https://excelfox.com/forum/showthrea...cell-in-sheet2

Code:

---

Sub ConsolidateLines_Solution2() '  https://excelfox.com/forum/showthread.php/2815-Copy-data-from-multiple-rows-between-two-keyword-and-paste-the-data-in-row(s)-of-single-cell-in-sheet2
Rem 0 worksheets data info
Dim Ws1 As Worksheet, Ws2 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1): Set Ws2 = ThisWorkbook.Worksheets.Item(2)
Dim Lr As Long: Let Lr = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
 
Rem 3 Initial to get started, finding first start point of text we want
 Dim RngStt As Range ' This will be the cell with the first  Keywrod1
  Set RngStt = Ws1.Range("A1:A" & Lr & "").Find(What:="Keywrod1", After:=Ws1.Range("A" & Lr & ""), LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
Rem 4 main text manipulation
'4a)
    Do While Not RngStt Is Nothing ' This the main outer loop will terminate if we find no new first keyword #####
    Dim RngStp As Range ' This willl be the cell with the next  Keyword2
    Set RngStp = Ws1.Range("A" & RngStt.Row + 1 & ":A" & Lr & "").Find(What:="Keyword2", After:=Ws1.Range("A" & RngStt.Row + 1 & ""), LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        If RngStp Is Nothing Then Exit Do  ' This is for the case of if there is no Keyword2  after  a found  Keywrod1
'4b)
    Dim Rw As Long
        For Rw = RngStt.Row To RngStp.Row Step 1 ' We loop through the cells in between and including the cells with  Keywrod1  and  keyword2
        Dim NewCelStr As String ' This is used to build the string for a new cell
        Let NewCelStr = NewCelStr & Ws1.Range("A" & Rw & "").Value2 & vbLf  ' Add the next cell text followed by a new line character
        Next Rw
    Let NewCelStr = Left(NewCelStr, Len(NewCelStr) - 1)
    Dim Lr2 As Long: Let Lr2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row
    Let Ws2.Range("A" & Lr2 + 1 & "").Value = NewCelStr
'4c(ii)
    Let NewCelStr = ""
    Set RngStt = Ws1.Range("A" & RngStp.Row & ":A" & Lr + 1 & "").Find(What:="Keywrod1", After:=Ws1.Range("A" & RngStp.Row + 1 & ""), LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
    Loop ' While Not RngStt = Nothing '  ### Main outer loop terminates when main text manipulation is finished ##
 
 
 Ws2.Columns(1).WrapText = False
End Sub

---

Second solution, Solution 2 for this thread
https://excelfox.com/forum/showthrea...cell-in-sheet2

Code:

---

Sub ConsolidateLines_Solution2() '  https://excelfox.com/forum/showthread.php/2815-Copy-data-from-multiple-rows-between-two-keyword-and-paste-the-data-in-row(s)-of-single-cell-in-sheet2
Rem 0 worksheets data info
Dim Ws1 As Worksheet, Ws2 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1): Set Ws2 = ThisWorkbook.Worksheets.Item(2)
Dim Lr As Long: Let Lr = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
 
Rem 3 Initial to get started, finding first start point of text we want
 Dim RngStt As Range ' This will be the cell with the first  Keywrod1
  Set RngStt = Ws1.Range("A1:A" & Lr & "").Find(What:="Keywrod1", After:=Ws1.Range("A" & Lr & ""), LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
Rem 4 main text manipulation
'4a)
    Do While Not RngStt Is Nothing ' This the main outer loop will terminate if we find no new first keyword #####
    Dim RngStp As Range ' This willl be the cell with the next  Keyword2
    Set RngStp = Ws1.Range("A" & RngStt.Row + 1 & ":A" & Lr & "").Find(What:="Keyword2", After:=Ws1.Range("A" & RngStt.Row + 1 & ""), LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        If RngStp Is Nothing Then Exit Do  ' This is for the case of if there is no Keyword2  after  a found  Keywrod1
'4b)
    Dim Rw As Long
        For Rw = RngStt.Row To RngStp.Row Step 1 ' We loop through the cells in between and including the cells with  Keywrod1  and  keyword2
        Dim NewCelStr As String ' This is used to build the string for a new cell
        Let NewCelStr = NewCelStr & Ws1.Range("A" & Rw & "").Value2 & vbLf  ' Add the next cell text followed by a new line character
        Next Rw
    Let NewCelStr = Left(NewCelStr, Len(NewCelStr) - 1)
    Dim Lr2 As Long: Let Lr2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row
    Let Ws2.Range("A" & Lr2 + 1 & "").Value = NewCelStr
'4c(ii)
    Let NewCelStr = ""
    Set RngStt = Ws1.Range("A" & RngStp.Row & ":A" & Lr + 1 & "").Find(What:="Keywrod1", After:=Ws1.Range("A" & RngStp.Row + 1 & ""), LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
    Loop ' While Not RngStt = Nothing '  ### Main outer loop terminates when main text manipulation is finished ##
 
 
 Ws2.Columns(1).WrapText = False
End Sub

---

In support of this forum post
https://eileenslounge.com/viewtopic.php?f=30&t=38895

This is Hans final working Solution

Code:

---

'    Hans  https://eileenslounge.com/viewtopic.php?p=300746#p300746
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Pee As String
On Error GoTo Myerror
 Let Application.EnableEvents = False
'    If Not Intersect(Target, Columns(1)) Is Nothing Then
        For Each Rng In Intersect(Target, Columns(1))
        Let Pee = Replace(Replace(Evaluate("Proper(""" & Rng.Value & """)"), " ", ""), "-", "")
            Select Case Pee
                Case "A"
                Let Rng.Value = "ABC"
                Case "Aa"
                Let Rng.Value = "XXD"
                Case Else
                Rng.ClearContents
            End Select
        Next Rng
'    End If
Myerror:
 Let Application.EnableEvents = True
End Sub


---

---

We can pretty this via Evaluate Range up in two main ways
_ The VBA Replace ideas can be replaced in the Evaluate by Excel spreadsheet SUBSTITUTE
_ The VBA Select Case ideas can be replaced by the Excel spreadsheet IF

The full coding example here follows approximately the Excel spreadsheet workings in the uploaded file. (In that file my workings are for the example range D11:D12 being copied and pasted into column 1, range A11:A12)
Note that in some steps the trick IF({1},___) was needed to get more than one result, but it was often found that in subsequent steps this could be removed. I expect this is because whatever phenomena is going on in that trick, goes on when we introduce steps involving IFs on multi cell ranges, so then the trick is redundant.

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)  '  https://excelfox.com/forum/showthread.php/2834-Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=19028&viewfull=1#post19028
Dim Pee As String '  , Rng As Range
On Error GoTo Myerror
 Let Application.EnableEvents = False
    If Not Intersect(Target, Columns(1)) Is Nothing Then
    Dim varTest As Variant
    Let varTest = Evaluate("=IF({1},PROPER(" & Target.Address & "))")
    Let varTest = Evaluate("=IF({1},SUBSTITUTE(IF({1},PROPER(" & Target.Address & ")),"" "",""""))")
    Let varTest = Evaluate("=IF({1},SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""))")
    Let varTest = Evaluate("=IF({1},SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"",""""))")
    Let varTest = Evaluate("=IF(IF({1},SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"",""""))=""A"",""ABC"",""x"")")
    Let varTest = Evaluate("=IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""A"",""ABC"",""x"")")
    Let varTest = Evaluate("=IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""A"",""ABC"",IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""Aa"",""XXD"",""""))")
    'Let Target.Value2 = varTest
    Let Target.Value2 = Evaluate("=IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""A"",""ABC"",IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""Aa"",""XXD"",""""))")
'        For Each Rng In Intersect(Target, Columns(1))
'        Let Pee = Replace(Replace(Evaluate("Proper(""" & Rng.Value & """)"), " ", ""), "-", "")
'            Select Case Pee
'                Case "A"
'                Let Rng.Value = "ABC"
'                Case "Aa"
'                Let Rng.Value = "XXD"
'                Case Else
'                Rng.ClearContents
'            End Select
'        Next Rng
    Else
    ' case not pasted in column 1
    End If
Myerror:
 Let Application.EnableEvents = True
End Sub


---

In support of this forum post
https://eileenslounge.com/viewtopic.php?f=30&t=38895

This is Hans final working Solution

Code:

---

'    Hans  https://eileenslounge.com/viewtopic.php?p=300746#p300746
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Pee As String
On Error GoTo Myerror
 Let Application.EnableEvents = False
'    If Not Intersect(Target, Columns(1)) Is Nothing Then
        For Each Rng In Intersect(Target, Columns(1))
        Let Pee = Replace(Replace(Evaluate("Proper(""" & Rng.Value & """)"), " ", ""), "-", "")
            Select Case Pee
                Case "A"
                Let Rng.Value = "ABC"
                Case "Aa"
                Let Rng.Value = "XXD"
                Case Else
                Rng.ClearContents
            End Select
        Next Rng
'    End If
Myerror:
 Let Application.EnableEvents = True
End Sub


---

---

We can pretty this via Evaluate Range up in two main ways
_ The VBA Replace ideas can be replaced in the Evaluate by Excel spreadsheet SUBSTITUTE
_ The VBA Select Case ideas can be replaced by the Excel spreadsheet IF

The full coding example here follows approximately the Excel spreadsheet workings in the uploaded file. (In that file my workings are for the example range D11:D12 being copied and pasted into column 1, range A11:A12)
Note that in some steps the trick IF({1},___) was needed to get more than one result, but it was often found that in subsequent steps this could be removed. I expect this is because whatever phenomena is going on in that trick, goes on when we introduce steps involving IFs on multi cell ranges, so then the trick is redundant.

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)  '  https://excelfox.com/forum/showthread.php/2834-Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=19028&viewfull=1#post19028
Dim Pee As String '  , Rng As Range
On Error GoTo Myerror
 Let Application.EnableEvents = False
    If Not Intersect(Target, Columns(1)) Is Nothing Then
    Dim varTest As Variant
    Let varTest = Evaluate("=IF({1},PROPER(" & Target.Address & "))")
    Let varTest = Evaluate("=IF({1},SUBSTITUTE(IF({1},PROPER(" & Target.Address & ")),"" "",""""))")
    Let varTest = Evaluate("=IF({1},SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""))")
    Let varTest = Evaluate("=IF({1},SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"",""""))")
    Let varTest = Evaluate("=IF(IF({1},SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"",""""))=""A"",""ABC"",""x"")")
    Let varTest = Evaluate("=IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""A"",""ABC"",""x"")")
    Let varTest = Evaluate("=IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""A"",""ABC"",IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""Aa"",""XXD"",""""))")
    'Let Target.Value2 = varTest
    Let Target.Value2 = Evaluate("=IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""A"",""ABC"",IF(SUBSTITUTE(SUBSTITUTE(PROPER(" & Target.Address & "),"" "",""""),""-"","""")=""Aa"",""XXD"",""""))")
'        For Each Rng In Intersect(Target, Columns(1))
'        Let Pee = Replace(Replace(Evaluate("Proper(""" & Rng.Value & """)"), " ", ""), "-", "")
'            Select Case Pee
'                Case "A"
'                Let Rng.Value = "ABC"
'                Case "Aa"
'                Let Rng.Value = "XXD"
'                Case Else
'                Rng.ClearContents
'            End Select
'        Next Rng
    Else
    ' case not pasted in column 1
    End If
Myerror:
 Let Application.EnableEvents = True
End Sub


---

spare post for later

spare post for later