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

**DocAElstein** · 08-31-2020, 03:24 PM

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

**DocAElstein** · 09-02-2020, 12:45 PM

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

**DocAElstein** · 09-03-2020, 03:24 PM

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

**DocAElstein** · 09-15-2020, 01:03 PM

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

**DocAElstein** · 09-15-2020, 02:32 PM

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

**DocAElstein** · 09-22-2020, 02:12 PM

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

**DocAElstein** · 10-19-2020, 02:46 PM

post for later use,
posting to get URL limk now

**DocAElstein** · 11-06-2020, 11:05 AM

Code:

Sub test()
    SendKeys "%s{Enter}"
    MsgBox ("please just click OK")
End Sub

' https://excelfox.com/forum/showthrea...ll=1#post14885
' https://excelfox.com/forum/showthrea...ll=1#post14877
' https://excelfox.com/forum/showthrea...cting-the-Cell
' http://www.eileenslounge.com/viewtop...277023#p277023

**DocAElstein** · 11-06-2020, 11:06 AM

Insupport of this Thread post:
https://excelfox.com/forum/showthrea...5085#post15085

Code:

Sub MakeDropDownList1and2()  '   https://excelfox.com/forum/showthread.php/2676-Dependent-Drop-Down-Lists?p=15085&viewfull=1#post15085
Rem 1 worksheets info
Dim WsApp As Worksheet, WsComs As Worksheet
 Set WsApp = ThisWorkbook.Worksheets("Appraisal"): Set WsComs = ThisWorkbook.Worksheets("Comments")
Rem 2 FirstTwoDropDowns2
' 2a) List 1 in column A
 WsApp.Range("A2:A8").Validation.Delete
 WsApp.Range("A2:A8").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A1").Value & "," & WsComs.Range("A11").Value & "," & WsComs.Range("A21").Value & "," & WsComs.Range("A31").Value & ""

'2b) list 2 in column C
 WsComs.Range("C2:C8").Validation.Delete
 WsComs.Range("C2:C8").Validation.Add Type:=xlValidateList, Formula1:="" & WsComs.Range("A2").Value & "," & WsComs.Range("B2").Value & "," & WsComs.Range("C2").Value & ""
End Sub

**DocAElstein** · 11-06-2020, 12:02 PM

Continued in next post…._

_..... continued from last post
Worksheets info from OP:
Requirements:

1. Under "Social Competencies", the drop down list should contain all the headers from the sheet "Comments" (Color Code - Peach).

2. Under "Please Choose", the drop down list should contain "Does Not Meet Expectation", "Meets Expectation", "Exceeds Expectation" (Color Code - Grey).

3. So, If a person selects "Communicating Effectively" under Social Competencies column, and then selects "Meets Expectation" in the next column, then the drop down list on Column D "Please Choose" should display the list from B3:B8 from the sheet named "Comments".

Another example would be if a person selects "Resolving Conflict" under Social Competencies column, and then selects "Does Not Meet Expectation" in the next column, then the drop down list on Column D "Please Choose" should display the list from A13:A18 from the sheet named "Comments".

4. So, If a person selects "Sharing Information" under Social Competencies column, then the drop down list on Column E "Give Advise" should display the list from A28:A32 from the sheet named "Give Advise"

_____ Workbook: Appraisal - Drop Down.xls ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C
1	Communicating Effectively
2	Does Not Meet Expectation	Meets Expectation	Exceeds Expectation
3	Assumes understanding.	Actively listens.	Encourages others to share information.
4	Difficult to contact.	Communicates regularly with team members.	Excellent listener.
5	Does not adapt language to listener.	Communicates with team members.	Gives people full attention.
6	Does not give others full attention.	Conveys enthusiasm.	Promotes candid and open atmosphere.
7	Ideas and comments are hard to follow.	Gives people full attention.	Shares information with team.
8	Uses overly complex language.	Shares information with team.	Shares useful information.
9
10
11	Resolving Conflict
12	Does Not Meet Expectation	Meets Expectation	Exceeds Expectation
13	Becomes emotional dealing with conflict.	Avoids emotional involvement.	Diffuses conflicts before they start.
14	Gives up easily, misses opportunities.	Avoids unnecessary conflict.	Finds permanent fixes to tough conflicts.
15	Is caught off guard by conflicts.	Handles difficult people.	Handles difficult people easily.
16	Needs to focus on problems, not people.	Helps others end disputes.	Listens to all, hears all sides.
17	Shies away from conflict, lets it escalate.	Tries to find roots of conflict.	Top peacekeeper, solution-finder.
18	Too confrontational, focused on win-lose.	Uses good listening, communication skills.
19
20
21	Sharing Information
22	Does Not Meet Expectation	Meets Expectation	Exceeds Expectation
23	Does not communicate experience or knowledge to others.	Effectively communicates information and keeps teammates on the same page.	Carefully listens to what others have to say and adds insightful comments; asks important questions.
24	Does not listen to others.	Keep key players informed.	Conveys extremely complex information in a simple fashion.
25	Does not share relevant information to the team.	Knows the appropriate amount of knowledge to share with others.	Does not act aloof or arrogant, is humble and happy to help.
26	Does not speak up.	Prior to presenting and idea or sharing information, run it by someone first.	Helps foster and cultivate an environment that is open to exchange of information.
27	Shares too little information.	Shares useful information with teammates.	Informs the team with specific information to achieve and surpass goals.
28	Shares useless information.	Willingly shares leadership skills and knowledge with others.	Provides expert information and knowledge with teammates.
29
30
31	Supporting Co-workers
32	Does Not Meet Expectation	Meets Expectation	Exceeds Expectation
33	Could be more collaborative.	Appreciates others.	Able to resolve conflict.
34	Could be more open-minded.	Collaborates with others.	Excellent listening skills.
35	Does not respond to others' needs.	Helps resolve team conflicts.	Flexible and open-minded.
36	does not support new members	Proactively share information and suggestions to help new team members get up to speed as fast as possible.	Includes others.
37	Excessively critical of others.	Welcomes new team members.	Promotes team spirit.
38	Rarely accommodates others.	Willing to help.	Provides support.