Displaying cells with multi-line text 'elegantly'...

[wabbit_47]

Hi Excel Gurus

Like many, I'm a bit of a VBA/Macro 'Noob' but I'm hoping there might be someone out there with an 'elegant' solution to this problem for me...

I've been developing a large spreadsheet (approx 26 columns) and ongoing/infinite rows. Each row entry is filled in by a userform and entered by hitting the 'Submit' button which pastes everything from the forms textboxes, comboboxes, DTPickers, etc into the corresponding columns automatically and all is working ticketty-boo except for 3 of the columns, all with the same problem.

The troublesome three are all entered into the sheet via a textbox on the userform just like the others, only they all contain large quantities of text. I'm trying to figure out a way of displaying this text in the actual cell (after submitting the form) without altering the row height (keeping it all to an 'elegant' 15.00), but still maintaining the ability to search for text in the cells....perhaps some kind of 'hover-over' display or the like?

The macro to paste the information into the spreadsheet is triggered by a submit button on the userform that is coded as below...

Private Sub CommandButton1_Click()
    Dim LastRow As Object
 
 
    Set LastRow = Sheet1.Range("a65536").End(xlUp)
 
    LastRow.Offset(1, 0).Value = DTPicker1.Value
    LastRow.Offset(1, 1).Value = DTPicker2.Value
    LastRow.Offset(1, 2).Value = TextBox3.Text
    LastRow.Offset(1, 3).Value = TextBox4.Text
    LastRow.Offset(1, 4).Value = TextBox5.Text
    LastRow.Offset(1, 5).Value = ComboBox7.Text
    LastRow.Offset(1, 6).Value = DTPicker3.Value
    LastRow.Offset(1, 7).Value = TextBox6.Text
    LastRow.Offset(1, 8).Value = TextBox7.Text
    LastRow.Offset(1, 9).Value = Replace(FutureMovementsForm.TextBox8.Text, vbCrLf, vbLf, 1, -1, vbTextCompare)
    Me.Hide
    LastRow.Offset(1, 10).Value = TextBox9.Text
    LastRow.Offset(1, 11).Value = TextBox10.Text
    LastRow.Offset(1, 12).Value = TextBox11.Text
    LastRow.Offset(1, 13).Value = TextBox12.Text
    LastRow.Offset(1, 14).Value = TextBox13.Text
    LastRow.Offset(1, 15).Value = TextBox14.Text
    LastRow.Offset(1, 16).Value = ComboBox1.Text
    LastRow.Offset(1, 17).Value = TextBox16.Text
    LastRow.Offset(1, 18).Value = ComboBox2.Text
    LastRow.Offset(1, 19).Value = ComboBox3.Text
    LastRow.Offset(1, 20).Value = ComboBox4.Text
    LastRow.Offset(1, 21).Value = ComboBox5.Text
    LastRow.Offset(1, 22).Value = ComboBox6.Text
    LastRow.Offset(1, 23).Value = Replace(FutureMovementsForm.TextBox22.Text, vbCrLf, vbLf, 1, -1, vbTextCompare)
    Me.Hide
    LastRow.Offset(1, 24).Value = Replace(FutureMovementsForm.TextBox23.Text, vbCrLf, vbLf, 1, -1, vbTextCompare)
    Me.Hide
    MsgBox "One record written to the shedule"
 
    response = MsgBox("Do you want to enter another record?", _
        vbYesNo)
 
    If response = vbYes Then
 
        TextBox3.Text = ""
        TextBox4.Text = ""
        TextBox5.Text = ""
        TextBox6.Text = ""
        TextBox7.Text = ""
        TextBox8.Text = ""
        TextBox9.Text = ""
        TextBox10.Text = ""
        TextBox11.Text = ""
        TextBox12.Text = ""
        TextBox13.Text = ""
        TextBox14.Text = ""
        TextBox16.Text = ""
        TextBox22.Text = ""
        TextBox23.Text = ""
        ComboBox1.Text = ""
        ComboBox2.Text = ""
        ComboBox3.Text = ""
        ComboBox4.Text = ""
        ComboBox5.Text = ""
        ComboBox6.Text = ""
        ComboBox7.Text = ""
 
 
        DTPicker1.SetFocus
 
      Else
          Unload Me
      End If
 
 
End Sub

Textboxes 8, 22 and 23 are the ones with multiple lines. The code that starts with "Replace(FutureMovementsForm...." is to prevent the square boxes with the question marks appearing in the cells.

Long-winded but hopefully detailed and specific enough that you might have a few possible solutions

Cheers to you in advance
Wabbit_47

 

[jmcdaid]

I've further improved my code above to avoid an error when a cell in the final column is selected and Excel cannot place a shape to the right of that cell.

In the following code, the shape is not shown under these circumstances. You'll need to modify the code if you would like shapes to appear near the outer boundaries of the workbook but I think this code will suit most users needs.

HTH
Joe
http://www.spreadsheetstudio.com

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    Const SHAPENAME As String = "MessageShape"
    Dim ws As Worksheet
    Dim oshp As Shape
    Dim icount As Integer
    Dim iX As Integer
    Dim iY As Integer
    Dim iHeight As Integer
    Dim iWidth As Integer
    
    Set ws = ActiveSheet
    
    'Only run if one cell is selected
    If Target.Count > 1 Then Exit Sub
    
    'Delete any existing shapes. We run though all shapes backwards
    For icount = ws.Shapes.Count To 1 Step -1
        Set oshp = ws.Shapes(icount)
        If (oshp.Name = SHAPENAME) Then
            oshp.Delete
        End If
    Next icount
    
    'The following code may error if the shape appears beyond the workbook boundries.
    'Under these circumstances we just abort.
    On Error GoTo done
    
    'Lets grab the position of the selected cell, we'll use this to place the message box just to the right of it
    iX = Target.Cells(1, 2).Left + 5
    iY = Target.Top + 5
    iHeight = 60
    iWidth = 200
    
    'Show the message box - Amend this if you want to change the position
    Select Case Target.Column
            Case 10, 11, 25, 26
            Set oshp = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, iX, iY, iWidth, iHeight)
            oshp.TextFrame2.TextRange.Characters.Text = Target.Value
            oshp.Name = SHAPENAME
    End Select

done:

End Sub

 

[KrazyAl]

Thank you all! The above code is what I was searching for also. Is it possible to change the color of the text box?

Thank you .. you guys rock!

Ray

 

[jmcdaid]

Sure can, just add the following code after the oshape.TextFrame2 line. Adjust the RGB as required.

HTH
Joe
http://www.spreadsheetstudio.com

oshp.Fill.ForeColor.RGB = RGB(160, 160, 200)

 

[KrazyAl]

Thank you jmcdaid!

Much appreciated

 

[ZVI]

Here is another way, just for interest.
Put the below code into ThisWorkbook module
Code plays in all sheets for the cells with multiline text only.
The validation style message appears below the cell.
Line feed (vbLf) character in cell's value is the trigger for that message.

'Code of ThisWorkbook module

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  ShowMultiLineText
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  ShowMultiLineText
End Sub

Private Sub ShowMultiLineText()
  Dim v
  v = ActiveCell
  If Not VarType(v) = vbString Then Exit Sub
  If InStr(v, vbLf) = 0 Then Exit Sub
  On Error Resume Next
  Names("ActiveCell.Previous").RefersToRange.Validation.Delete
  With ActiveCell.Validation
    .Delete
    .Add xlValidateInputOnly, xlValidAlertStop, xlBetween
    .InputMessage = v
  End With
  Names.Add "ActiveCell.Previous", ActiveCell, Visible:=False
End Sub

 

[taurean]

Both approaches are nice! Thanks for your input guys [jmcdaid and ZVI].

 

[GTS]

I've further improved my code above to avoid an error when a cell in the final column is selected and Excel cannot place a shape to the right of that cell.

In the following code, the shape is not shown under these circumstances. You'll need to modify the code if you would like shapes to appear near the outer boundaries of the workbook but I think this code will suit most users needs.

HTH
Joe
Spreadsheet StudioSpreadsheet Studio

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    Const SHAPENAME As String = "MessageShape"
    Dim ws As Worksheet
    Dim oshp As Shape
    Dim icount As Integer
    Dim iX As Integer
    Dim iY As Integer
    Dim iHeight As Integer
    Dim iWidth As Integer
    
    Set ws = ActiveSheet
    
    'Only run if one cell is selected
    If Target.Count > 1 Then Exit Sub
    
    'Delete any existing shapes. We run though all shapes backwards
    For icount = ws.Shapes.Count To 1 Step -1
        Set oshp = ws.Shapes(icount)
        If (oshp.Name = SHAPENAME) Then
            oshp.Delete
        End If
    Next icount
    
    'The following code may error if the shape appears beyond the workbook boundries.
    'Under these circumstances we just abort.
    On Error GoTo done
    
    'Lets grab the position of the selected cell, we'll use this to place the message box just to the right of it
    iX = Target.Cells(1, 2).Left + 5
    iY = Target.Top + 5
    iHeight = 60
    iWidth = 200
    
    'Show the message box - Amend this if you want to change the position
    Select Case Target.Column
            Case 10, 11, 25, 26
            Set oshp = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, iX, iY, iWidth, iHeight)
            oshp.TextFrame2.TextRange.Characters.Text = Target.Value
            oshp.Name = SHAPENAME
    End Select

done:

End Sub

This thread has been most informative / excellent.

The above code does 'almost' exactly what I want.
I know that I can adjust the size of the text box. What I'm wondering is, is it possible to modify the code so that the text box auto-sizes?
I have cells that range from just a few lines of content to several dozens of lines. Sizing the box for the largest case scenario results in a lot of white space.
I could live with a fixed width (the content is Alt-Enter wrapped), but I would love it if the length of the box was variable.
I could also live with a 'stepped' solution. For example, if character count in cell <200, then "x" length. If 200 to 500, then "y" length. etc. About 5 steps like this would suffice. It doesn't have to be based on characters; that's just an example.

Looking forward to any ideas that anyone has. TIA.

 

[GTS]

I searched a bit further and looked at other similar code.
I tried adding the following line (see below) into the code and it works perfectly.
It only impacts the length of the textbox as far as I can tell.
The width stays as set, but that works perfectly for me.

Code snippet...

'Show the message box - Amend this if you want to change the position
    Select Case Target.Column
            Case 10, 11, 25, 26
            Set oshp = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, iX, iY, iWidth, iHeight)
            oshp.TextFrame2.TextRange.Characters.Text = Target.Value
            oshp.TextFrame2.AutoSize = msoAutoSizeShapeToFitText 'Added line of code
            oshp.Name = SHAPENAME
    End Select

 

[surentash]

Hi all. I'm trying to accomplish a similar outcome but in an actual cell vs. a text box. So I have a range H1: H20 on a worksheet titled Test. I would like users to type comments within any cell within the range. The comments logged would wrap but the row height will be preserved. Hovering over the cell will display the underlying comment.

Any feedback/ solution would be sincerely appreciated!

Suren

 

[taurean]

There's no mouse hovering event associated with cells.