VBA Help - When max char limit is reached, place text in next row below.

[noveske]

I want to place a larger body of text in A1 on Sheet1. With the cells having a 110 character limit. Once reached, I want to continue breaking the body of text into 110 chars and placed in the cell below.
So far I have done this successfully, but I need the words to stay together and not get cut off. I'm sure the code I am using is the worst way to do it. So would like to start from scratch.

I've spent so much time and I finally broke to ask for help.

Lorem ipsum dolor sit amet. Et voluptates molestiae quo voluptas illum ut distinctio iusto et cumque labore vel repellendus dolorem. Et laborum esse At galisum voluptatum quo iusto voluptatem. Aut numquam repellat ad saepe possimus et labore dolorum ut quasi distinctio. Qui earum nostrum qui consequatur ipsa ut inventore repellendus alias aspernatur aut quis molestiae ea rerum beatae.

A1	Lorem ipsum dolor sit amet. Et voluptates molestiae quo voluptas illum ut distinctio iusto et cumque
A2	labore vel repellendus dolorem. Et laborum esse At galisum voluptatum quo iusto voluptatem. Aut numquam
A3	repellat ad saepe possimus et labore dolorum ut quasi distinctio. Qui earum nostrum qui consequatur ipsa ut
A4	inventore repellendus alias aspernatur aut quis molestiae ea rerum beatae.

This is what I am using:

Private Sub Worksheet_Change(ByVal Target As Range)        Dim r%, c%, x%, iPos%, iOffset%, length%    Dim strOriginal$, strExtract$    Const CHARS_COUNT% = 110        If Target.Cells.Count > 1 Then Exit Sub        On Error GoTo MACROS_FAIL        Application.EnableEvents = False        strOriginal = Target.value    length = Len(strOriginal)    r = Target.Row - 1: c = Target.Column    iPos = 1        If length > CHARS_COUNT Then        While iPos <= length            strExtract = Mid$(strOriginal, iPos, CHARS_COUNT)            x = x + 1            If x > 3 Then                x = 0: iOffset = 1            Else                iOffset = 1            End If            r = r + iOffset            Cells(r, c) = strExtract            iPos = iPos + CHARS_COUNT        Wend    End If        Application.EnableEvents = True     Exit Sub MACROS_FAIL:    Application.EnableEvents = True    MsgBox "Error:" & Chr(10) & Err.Description, vbCritical     End Sub

 

[Peter_SSs]

Welcome to the MrExcel board!

See if this helps - just adjust the 'Const' line in the code.
Break text in Cell into multiple cells