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

[DocAElstein]

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

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

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

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


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