Line break in excel vba

I know this question is really old, but as I had the same needs, after searching SO and google, I found pieces of answers but nothing usable. So with those pieces and bites I made my solution that I share here.

What I needed

1. Knowing the column width in pixels
2. Be able to measure the length of a string in pixels in order to cut it at the dimension of the column

What I found

1. About the width in pixels of a column, I found this in Excel 2010 DocumentFormat :

To translate the value of width in the file into the column width value at runtime (expressed in terms of pixels), use this calculation:
=Truncate(((256 * {width} + Truncate(128/{Maximum Digit Width}))/256)*{Maximum Digit Width})
Even if it’s Excel 2010 format, it’s still working in Excel 2016. I’ll be able to test it soon against Excel 365.

1. About the width of a string in pixels, I used the solution proposed by @TravelinGuy in this question, with small corrections for typo and an overflow. By the time I’m writing this the typo is already corrected in his answer, but there is still the overflow problem. Nevertheless I commented his answer so there is everything over there for you to make it works flawlessly.

What I’ve done

Code three recursive functions working this way :

1. Function 1 : Guess the approximate place where to cut the sentence so if fits in the column and then call Function 2 and 3 in order to determine the right place. Returns the original string with CR (Chr(10)) characters in appropriate places so each line fits in the column size,
2. Function 2 : From a guessed place, try to add some more words in the line while this fit in the column size,
3. Function 3 : The exact opposite of function 2, so it retrieves words to the sentence until it fits in the column size.

Here is the code

Sub SplitLineTest()
    Dim TextRange As Range
    Set TextRange = FeuilTest.Cells(2, 2) 

 'Take the text we want to wrap then past it in multi cells
    Dim NewText As String
    NewText = SetCRtoEOL(TextRange.Value2, TextRange.Font.Name, TextRange.Font.Size, xlWidthToPixs(TextRange.ColumnWidth) - 5) '-5 to take into account 2 white pixels left and right of the text + 1 pixel for the grid
    
'Copy each of the text lines in an individual cell
    Dim ResultArr() As String
    ResultArr() = Split(NewText, Chr(10))
    TextRange.Offset(2, 0).Resize(UBound(ResultArr) + 1, 1).Value2 = WorksheetFunction.Transpose(ResultArr())
End Sub


Function xlWidthToPixs(ByVal xlWidth As Double) As Long
'Fonction to convert the size of an Excel column width expressed in Excel unit(Range.ColumnWidth) in pixels
'Parameters :   - xlWidth : that is the width of the column Excel unit
'Return :       - The size of the column in pixels
    
    Dim pxFontWidthMax As Long
    
    'Xl Col sizing is related to workbook default string configuration and depends of the size in pixel from char "0". We need to gather it
    With ThisWorkbook.Styles("Normal").Font
        pxFontWidthMax = pxGetStringW("0", .Name, .Size)    'Get the size in pixels of the '0' character
    End With
    
    'Now, we can make the calculation
    xlWidthToPixs = WorksheetFunction.Floor_Precise(((256 * xlWidth + WorksheetFunction.Floor_Precise(128 / pxFontWidthMax)) / 256) * pxFontWidthMax) + 5
End Function


Function SetCRtoEOL(ByVal Original As String, ByVal FontName As String, ByVal FontSize As Variant, ByVal pxAvailW) As String
'Function aiming to make a text fit into a given number of pixels, by putting some CR char between words when needed.
'If some words are too longs to fit in the given width, they won't be cut and will get out of the limits given.
'The function works recursively. Each time it find an End Of Line, it call itself with the remaining text until.
'The recursive process ends whent the text fit in the given space without needing to be truncated anymore
'Parameters :   - Original : The text to fit
'               - FontName : Name of the font
'               - FontSize : Size of the font
'               - pxAvailW : Available width in pixels in wich we need to make the text fit
'Return :       - The orignal text with CR in place of spaces where the text needs to be cut to fit the width
    
    'If we got a null string, there is nothing to do so we return a null string
    If Original = vbNullString Then Exit Function
    
    Dim pxTextW As Long
    
    'If the text fit in, may be it's the original or this is end of recursion. Nothing to do more than returne the text back
    pxTextW = pxGetStringW(Original, FontName, FontSize)
    If pxTextW < pxAvailW Then
        SetCRtoEOL = Original
        Exit Function
    End If
    
    'The text doesn't fit, we need to find where to cut it
    Dim WrapPosition As Long
    Dim EstWrapPosition As Long
    EstWrapPosition = Len(Original) * pxAvailW / pxTextW   'Estimate the cut position in the string given to a proportion of characters
    If pxGetStringW(Left(Original, EstWrapPosition), FontName, FontSize) < pxAvailW Then
        'Text to estimated wrap position fits in, we try to see if we can fits some more words
        WrapPosition = FindMaxPosition(Original, FontName, FontSize, pxAvailW, EstWrapPosition)
    End If
        
    'If WrapPosition = 0, we didn't get a proper place yet, we try to find the previous white space
    If WrapPosition = 0 Then
        WrapPosition = FindMaxPositionRev(Original, FontName, FontSize, pxAvailW, EstWrapPosition)
    End If
        
    'If WrapPosition is still 0, we are facing a too long word for the pxAvailable. We'll cut after this word what ever. (Means we must search for the first white space of the text)
    If WrapPosition = 0 Then
        WrapPosition = InStr(Original, " ")
    End If
    
    If WrapPosition = 0 Then
        'Words too long to cut, but nothing more to cut, we return it as is
        SetCRtoEOL = Original
    Else
        'We found a wrap position. We recurse to find the next EOL and construct our response by adding CR in place of the white space
        SetCRtoEOL = Left(Original, WrapPosition - 1) & Chr(10) & SetCRtoEOL(Right(Original, Len(Original) - WrapPosition), FontName, FontSize, pxAvailW)
    End If
End Function


Function FindMaxPosition(ByVal Text As String, ByVal FontName As String, ByVal FontSize As Variant, ByVal pxAvailW, ByVal WrapPosition As Long) As Long
'Function that finds the maximum number of words fitting in a given space by adding words until it get out of the maximum space
'The function is inteded to work on text with a "guessed" wrap position that fit in the space allowed
'The function is recursive. Each time it guesses a new position and the word still fits in the space, it calls itself with a further WrapPosition
'Parameters :   - Text : The text to fit
'               - FontName : Name of the font
'               - FontSize : Size of the font
'               - pxAvailW : Available width in pixels in wich we need to make the text fit
'               - WrapPosition : The initial wrap position, positionned someware in the text (WrapPosition < len(Text)) but inside pxAvailW
'Return :       - The position were the text must be wraped to put as much words as possible in pxAvailW, but without getting outside of it. If no position can be found, returns 0

    Dim NewWrapPosition As Long
    Static isNthCall As Boolean
    
    'Find next Whitespace position
    NewWrapPosition = InStr(WrapPosition, Text, " ")
            
    If NewWrapPosition = 0 Then Exit Function                                               'We can't find a wrap position, we return 0
    If pxGetStringW(Left(Text, NewWrapPosition - 1), FontName, FontSize) < pxAvailW Then    '-1 not to take into account the last white space
        'It still fits, we can try on more word
        isNthCall = True
        FindMaxPosition = FindMaxPosition(Text, FontName, FontSize, pxAvailW, NewWrapPosition + 1)
    Else
        'It doesnt fit. If it was the first call, we terminate with 0, else we terminate with previous WrapPosition
        If isNthCall Then
            'Not the first call, we have a position to return
            isNthCall = False                               'We reset the static to be ready for next call of the function
            FindMaxPosition = WrapPosition - 1              'Wrap is at the first letter of the word due to the function call FindMax...(...., NewWrapPosition + 1). The real WrapPosition needs to be minored by 1
        Else
            'It's the first call, we return 0 | Strictly speaking we can remove this part as FindMaxPosition is already 0, but it make the algo easier to read
            FindMaxPosition = 0
        End If
    End If
End Function


Function FindMaxPositionRev(ByVal Text As String, ByVal FontName As String, ByVal FontSize As Variant, ByVal pxAvailW, ByVal WrapPosition As Long) As Long
'Function working backward of FindMaxPosition. It finds the maximum number of words fitting in a given space by removing words until it fits the given space
'The function is inteded to work on text with a "guessed" wrap position that fit in the space allowed
'The function is recursive. Each time it guesses a new position and the word still doesn't fit in the space, it calls itself with a closer WrapPosition
'Parameters :   - Text : The text to fit
'               - FontName : Name of the font
'               - FontSize : Size of the font
'               - pxAvailW : Available width in pixels in wich we need to make the text fit
'               - WrapPosition : The initial wrap position, positionned someware in the text (WrapPosition < len(Text)), but outside of pxAvailW
'Return :       - The position were the text must be wraped to put as much words as possible in pxAvailW, but without getting outside of it. If no position can be found, returns 0

    Dim NewWrapPosition As Long
    
    NewWrapPosition = InStrRev(Text, " ", WrapPosition)
    'If we didn't found white space, we are facing a "word" too long to fit pxAvailW, we leave and return 0
    If NewWrapPosition = 0 Then Exit Function
    
    If pxGetStringW(Left(Text, NewWrapPosition - 1), FontName, FontSize) >= pxAvailW Then   '-1 not to take into account the last white space
        'It still doesnt fits, we must try one less word
        FindMaxPositionRev = FindMaxPositionRev(Text, FontName, FontSize, pxAvailW, NewWrapPosition - 1)
    Else
        'It fits, we return the position we found
        FindMaxPositionRev = NewWrapPosition
    End If
End Function

Known limitations

This code will work as long as the text in the cell has only one font and one font size. Here I assume that the font is not Bold nor Italic, but this can be easily handled by adding few parameters as the function measuring the string length in pixels is already able to do it.
I’ve made many test and I always got the same result than the autowrap function of Excel worksheet, but it may vary from one Excel version to an other. I assume it works on Excel 2010, and I tested it with success in 2013 and 2016. Fo others I don’t know.
If you need to handle cases where fonts type and/or attributs vary inside a given cell, I assume it’s possible to achieve it by testing the text in the cell character by character by using the range.caracters property. It should be really slower, but for now, even with texts to split in almost 200 lines, it takes less than one instant so maybe it’s viable.