Counting lines in a wrapped cell

[ebeauchamp28]

Trying to count the number of lines inside a wrapped cell. For example, if a long sentence wraps to 5 lines inside a cell, the function or macro should return "5".

The following thread seems to address a similar question, but I am wondering if a simpler solution exists: http://www.mrexcel.com/forum/showthread.php?t=148694&highlight=count+lines+wrap

Thanks in advance,
Erik

 

[KenMillard]

This should work for text in cell A1 of the active sheet.

Public Sub CountLines()
Dim H1 As Double
Dim H2 As Double
With Range("A1")
    .WrapText = False
    H1 = .Height
    .WrapText = True
    H2 = .Height
End With
MsgBox H2 / H1 & " Lines"

End Sub

 

[ebeauchamp28]

This works great. Instead of outputting to a msg box, how is it possible to output the value to the cell next to it (B1), and to loop through all values in the A column and output the results for each cell in column B? Thanks again.

 

[John_w]

Public Sub CountLines()
    Dim H1 As Double
    Dim H2 As Double
    Dim row As Long
    
    row = 1
    While Cells(row, 1).Value <> ""
        With Cells(row, 1)
            .WrapText = False
            H1 = .height
            .WrapText = True
            H2 = .height
            .Offset(0, 1).Value = H2 / H1
        End With
        row = row + 1
    Wend
    
End Sub

 

[ebeauchamp28]

Exactly the desired result. Thanks.

 

[theory]

This should work for text in cell A1 of the active sheet.

Public Sub CountLines()
Dim H1 As Double
Dim H2 As Double
With Range("A1")
    .WrapText = False
    H1 = .Height
    .WrapText = True
    H2 = .Height
End With
MsgBox H2 / H1 & " Lines"

End Sub

I have a lengthy sentence in cell "A1" and Wrap Text enabled in that cell. It wraps to 3 lines. There are no carriage returns.

When I run this macro it is returning "1 Lines" in the message box. Am I missing something?


Thanks!

 

[theory]

@John_w I suppose I should have replied to you instead as you are an active member. Please see my above comment if you have time. Thanks!

 

[John_w]

Welcome to MrExcel forums.

Are there any blank lines above and/or below the text? This would depend on the height of the cell and whether the vertical alignment is top, middle or bottom.

Try this macro, which operates on the active cell. Delete the 3 lines containing 'currentRowHeight' if you don't need to keep any blank lines above and/or below the text.

Public Sub CountLines_ActiveCell()
    Dim H1 As Double
    Dim H2 As Double
    Dim currentRowHeight As Double
    With ActiveCell
        currentRowHeight = .RowHeight  'save row height
        .EntireRow.AutoFit
        .WrapText = False
        H1 = .Height
        .WrapText = True
        H2 = .Height
        .RowHeight = currentRowHeight 'restore row height
    End With
    MsgBox H2 / H1 & " Lines"
End Sub

 

[theory]

Hey, I appreciate it.

The macro appears to be working well until I add a second column where the cells contain a different number of lines.

What I'm trying to do is use the max number of lines in a given row to force the row height to a specific value. We export tables from Excel to AutoCAD and using "Auto-Fit Row Height" causes all kinds of problems given the way that AutoCAD interprets the row heights. What we've found is that by setting row heights based on the max number of lines (ex. 1 line = row height of 18, 2 lines = row height of 30, 3 lines = row height of 42, etc.) works the best in this case. I have no idea how to do it because I am extremely new to VBA but it would save hours on every project given the frequency in which we update these tables.

Any advice is appreciated. Thanks.

 

[John_w]

See if this macro works better. Using the same WrapText = False/True technique as the previous macro, it works out the maximum number of lines for each row by copying each cell on Sheet1, one at a time, to A1 on a temporary sheet.

Public Sub Max_Lines_Each_Row()

    Dim H1 As Double
    Dim H2 As Double
    Dim r As Long, c As Long
    Dim maxLines As Long
    Dim tempSheet As Worksheet
    
    Set tempSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    
    With Worksheets("Sheet1")
        .Activate
        For r = 1 To .Cells(.Rows.Count, "A").End(xlUp).row
            Debug.Print "Row " & r & ": " & .Cells(r, 1).EntireRow.RowHeight,
            maxLines = 0
            For c = 1 To .Cells(r, .Columns.Count).End(xlToLeft).Column
                tempSheet.Range("A1").Clear
                .Cells(r, c).Copy tempSheet.Range("A1")
                tempSheet.Range("A1").EntireColumn.ColumnWidth = .Cells(r, c).EntireColumn.ColumnWidth
                With tempSheet.Range("A1")
                    .EntireRow.AutoFit
                    .WrapText = False
                    H1 = .Height
                    .WrapText = True
                    H2 = .Height
                End With
                Debug.Print H1 & " " & H2,
                If H2 / H1 > maxLines Then maxLines = H2 / H1
            Next
            Debug.Print maxLines
            MsgBox "Row " & r & ": max lines = " & maxLines
        Next
    End With
    
    Application.DisplayAlerts = False
    tempSheet.Delete
    Application.DisplayAlerts = True
    
End Sub