VBA If data selected from dropdown, then only allow specific Text Length

[HelloKhritty]

Hi Mr Excel,
I am having a hard time creating this project for I am new using VBA.
My problem is, I am creating a worksheet using vb where cell 1 contains dropdown list that if you choose the item 1, only 6 characters will be allowed on cell 2. Else, if item 2 was chosen, only allow 9 characters in cell 2.
Cell range is until where data is available.
Here's my code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim ws As Worksheet
Set ws = Worksheets("Sheet1")

'Column B
Dim Rng As Range
Set Rng = ws.Range("B2:B25") 'setting range of validation in worksheet (Column B, row2 - 25)

'Column A
Dim Courier As Range
Dim RowA As String
Set Courier = ws.Range("A2:A25") 'setting range for validation in worksheet (Column A)

If Courier.Value = "UPS" Then

'apply data validation
With Rng.Validation
.Delete
.Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, Operator:=xlEqual, Formula1:="6"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "Check Length"
.ErrorTitle = "Check #"
.ErrorMessage = "You can only enter a maximum of 6 characters only!"
.ShowInput = True
.ShowError = True
End With
ElseIf Courier.Value = "FedEx" Then
With Rng.Validation
.Delete
.Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, Operator:=xlEqual, Formula1:="9"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "Check Length"
.ErrorTitle = "Check #"
.ErrorMessage = "You can only enter a maximum of 9 characters only!"
.ShowInput = True
.ShowError = True
End With
End If

End Sub



sorry for the syntax errors I am new to this. Hope you can help MrExcel. Thank you.

 

[Siddharth Rout]

Couple of questions

1. How is the list being created for A2:A25? Named Range? Reference to another range? Manually typing values using ","?
2. Should the limitation be applied for only 1st 2 items from the list or for others as well? For example what if the user selects 3rd or the 10th item from the list?

 

[HelloKhritty]

Hi, thankbyou very much for the reply.
Ok,
So from excel sheet1 on columnA , I already set a List data validation with only 2 source,"UPS and FedEx". So if the user choose UPS, only 6 characters will allow on the second column. And if FedEx, 9 characters only. Client also added, third and fourth column that if 1 item was chosen on the 3rd column, the 4th will be disabled. So i have 2 items created via list, "direct and redirect" . Thank you so much

 

[Siddharth Rout]

Client also added, third and fourth column that if 1 item was chosen on the 3rd column, the 4th will be disabled. So i have 2 items created via list, "direct and redirect" . Thank you so much

I am afaraid, I did not uderstand what is the requirement here. You may want to expand a little on that? As per the original request, what you need is not Worksheet_SelectionChange but Worksheet_Change event.

Is this what you are trying? Paste this in the relevant sheet code module.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Whoa
    
    Application.EnableEvents = False
    
    Dim aCell As Range
    Dim RestrictedLength As Long
    
    '~~> Check if the change happened in the range A2:A25
    If Not Intersect(Target, Range("A2:A25")) Is Nothing Then
        '~~> Check all changed cells (if applicable)
        For Each aCell In Target
            '~~> Decide the text length
            Select Case aCell.Value
                Case "UPS": RestrictedLength = 6
                Case "FedEx": RestrictedLength = 9
            End Select
            
            '~~> Apply the validation
            With Range("B" & aCell.Row).Validation
                .Delete
                .Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
                           Operator:=xlEqual, Formula1:=RestrictedLength
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = "Check Length"
                .ErrorTitle = "Check #"
                .ErrorMessage = "You can only enter a maximum of " & _
                                RestrictedLength & " characters only!"
                .ShowInput = True
                .ShowError = True
            End With
        Next aCell
    End If
    
Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Sub

 

[HelloKhritty]

I am afaraid, I did not uderstand what is the requirement here. You may want to expand a little on that? As per the original request, what you need is not Worksheet_SelectionChange but Worksheet_Change event.

Is this what you are trying? Paste this in the relevant sheet code module.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Whoa
   
    Application.EnableEvents = False
   
    Dim aCell As Range
    Dim RestrictedLength As Long
   
    '~~> Check if the change happened in the range A2:A25
    If Not Intersect(Target, Range("A2:A25")) Is Nothing Then
        '~~> Check all changed cells (if applicable)
        For Each aCell In Target
            '~~> Decide the text length
            Select Case aCell.Value
                Case "UPS": RestrictedLength = 6
                Case "FedEx": RestrictedLength = 9
            End Select
           
            '~~> Apply the validation
            With Range("B" & aCell.Row).Validation
                .Delete
                .Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
                           Operator:=xlEqual, Formula1:=RestrictedLength
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = "Check Length"
                .ErrorTitle = "Check #"
                .ErrorMessage = "You can only enter a maximum of " & _
                                RestrictedLength & " characters only!"
                .ShowInput = True
                .ShowError = True
            End With
        Next aCell
    End If
   
Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Sub

It works really well, Thank you so so so so so much !!!!

 

[Siddharth Rout]

It works really well, Thank you so so so so so much !!!!

Thanks for the feedback