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
Reply With Quote
Bookmarks