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

In support of this Thread answer

List table supplied by OP in uploade file

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

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

Worksheet: Sheet1


I am not sure why get those strange black areas , so I did a find on [td=bgcolor:#000000] replacing withnothing


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

Row\Col	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY	AZ	BA	BB
15
16
17
18
19
20
21
22
23
24

Worksheet: Sheet1

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

_....see next post

_... from last post

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

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

Worksheet: Sheet1

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

Just testing in this post.....


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

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

Worksheet: Sheet1

Solution for ( part A) ) of this Thread
https://excelfox.com/forum/showthrea...ll=1#post14870

Code:

---

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

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



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

---

Answer to this Thread post:
https://excelfox.com/forum/showthrea...ll=1#post14873

Code:

---

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

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

End Sub


---

In support of this püost:
https://excelfox.com/forum/showthrea...ll=1#post14877

Code:

---

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

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

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


End Sub

---

Code:

---

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

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

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

End Sub

---

First macro for this Post:
https://excelfox.com/forum/showthrea...4913#post14913

Code:

---

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

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


---

Final macro for this post
https://excelfox.com/forum/showthrea...4913#post14913

Code:

---

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

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

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

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


---

macro solution for this post:
https://excelfox.com/forum/showthrea...ll=1#post14955

Code:

---

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

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

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


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




---

post for later use,
posting to get URL limk now