How to replace the data validation input message with a textbox

Question

Input message data validation is limited to 255 characters and 9 lines. How would like to replace it with a textbox. Would it be possible? Here you go my code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim arr, cellVal As Variant
    Set rng = Range("A1:A10")
    arr = rng.Value
    If Not Intersect(Target, rng) Is Nothing Then

    For i = 1 To rng.Rows.Count
        For j = 1 To rng.Columns.Count
            cellVal = arr(i, j)
            Select Case cellVal
              Case Is = "A"
                  rng(i, j).Validation.InputMessage = "Presentation and history:" & vbTab & vbCrLf & _
                "One eye or both eyes" & vbTab & vbCrLf & _
                "Gritty sensation/itch versus pain" & vbTab & vbCrLf & _
                "Photophobia" & vbTab & vbCrLf & _
                "Visual change" & vbTab & vbCrLf & _
                "Discharge present" & vbTab & vbCrLf & _
                "Injury" & vbTab & vbCrLf & _
                "Foreign body" & vbTab & vbCrLf & _
                "History of allergy or hay fever" & vbTab
              Case Is = "B"
                  rng(i, j).Validation.InputMessage = TextBox1.Text
              Case Is = "C"
                  rng(i, j).Validation.InputMessage = "Carrot"
              Case Else
                  rng(i, j).Validation.InputMessage = "Something   else"
            End Select
        Next j
    Next i
    End If
End Sub

Case "A" shows the limit of the data validation message. I would like to replace it with TextBox1 as shown in case "B". Please let me know if it is possible. Regards Tommaso

Answer 1

You can mimic the behaviour by making various text boxes visible like so:

first create a number or ordinary text boxes - using multiple fonts, font sizes, colors, bells & whistles

then write a Selection_Change trigger ... very similar to what you did (noting that text boxes from the Insert menu are Shapes() )

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim MyTB As Shape
    ' hide all boxes
    ActiveSheet.Shapes("TextBox 1").Visible = msoFalse
    ActiveSheet.Shapes("TextBox 2").Visible = msoFalse
    ActiveSheet.Shapes("TextBox 3").Visible = msoFalse

    ' working on B1:B10 in order not to disturb data validation in A1:A10
    If Not Intersect(Target, [B1:B10]) Is Nothing Then

        ' assign correct TextBox to MyTB
        Select Case Target.Value
            Case "A", "a"
                Set MyTB = ActiveSheet.Shapes("TextBox 1")
            Case "B", "b"
                Set MyTB = ActiveSheet.Shapes("TextBox 2")
            Case Else
                Set MyTB = ActiveSheet.Shapes("TextBox 3")
        End Select

        ' position MyTB one cell right/down from Cursor (Target) and make visible
        MyTB.Left = Target(1, 2).Left
        MyTB.Top = Target(2, 2).Top
        MyTB.Visible = msoTrue

    End If
End Sub

and you should be done ?!?

(TextBox content thankfully stolen from https://www.lipsum.com/)