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

[DocAElstein]

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

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

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

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

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