Fixing the macro for text splitting (rows being skipped)

[azur3]

Hello everyone,

Im trying to derust my VBA skills and am pretty sure this macro is fully feasible to fix as I have been using similar in the past.
What I need:
- Im pasting unformatted text into column A,
- Each of the rows can contain a random amount of characters <1,+inf)
- The macro is supposed to split the text into max 35 character per row and then move the remaining text into the next row without losing any text
- I do not care about text being split in the middle of word

What I have built from memory (enhanced a bit by AI but it broke it even more to be honest):

Sub SplitTextIntoRows()
    Dim ws As Worksheet
    Dim cell As Range
    Dim originalText As String
    Dim newText As String
    Dim rowNum As Long
    Dim colNum As Long
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your sheet name
    
    ' Loop through each cell in column A
    For Each cell In ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        originalText = cell.Value
        rowNum = cell.Row
        colNum = cell.Column
        
        ' Clear the cell before adding new values
        cell.ClearContents
        
        ' Split the text into rows of 35 characters each
        Do While Len(originalText) > 0
            ' Check if the remaining text is less than or equal to 35 characters
            If Len(originalText) <= 35 Then
                ' If the remaining text fits within the current cell, set the value and exit the loop
                cell.Value = originalText
                Exit Do
            Else
                ' Split the text at 35 characters
                newText = Left(originalText, 35)
                originalText = Mid(originalText, 36)
                ' Move to the next cell in the column
                If ws.Cells(rowNum + 1, colNum).Value <> "" Then
                    rowNum = rowNum + 1
                    ws.Cells(rowNum, colNum).EntireRow.Insert
                Else
                    rowNum = rowNum + 1
                End If
                ' Set the value in the next cell
                ws.Cells(rowNum, colNum).Value = newText
            End If
        Loop
    Next cell
End Sub

Issues I am facing:

Out of

1 Lorem ipsum dolor sit amet, consectetur adipiscing elit. In leo justo, scelerisque a consequat at,

.

2 Sed efficitur accumsan ante, tincidunt tempor lacus accumsan nec

.

3 Morbi ipsum

.

4. Aliquam blandit fermentum lacus ut malesuada. Praesent pretium ex nec mi fringilla dignissim

I am getting

o, scelerisque a consequat at,

1 Lorem ipsum dolor sit amet, conse

ctetur adipiscing elit. In leo just

.

idunt tempor lacus accumsan nec

2 Sed efficitur accumsan ante, tinc

.

3 Morbi ipsum

.

ec mi fringilla dignissim

4. Aliquam blandit fermentum lacus

ut malesuada. Praesent pretium ex n

Which is a complete gibberish. Does any one have a clue on what is wrong here?
Thanks in advance.

 

[Akuini]

Using your example, what the result should look like?

 

[azur3]

Using your example, what the result should look like?

I am expecting it to look like below:

1 Lorem ipsum dolor sit amet, conse
ctetur adipiscing elit. In leo just
o, scelerisque a consequat at,
.
2 Sed efficitur accumsan ante, tinc
idunt tempor lacus accumsan nec
.
3 Morbi ipsum
.
4. Aliquam blandit fermentum lacus
ut malesuada. Praesent pretium ex n
ec mi fringilla dignissim

 

[Georgiboy]

Here is what I was playing with:

Sub test()
    Dim txt As String, var() As Variant
    Dim i As Long, x As Long, y As Long, z As Long
    Dim ws As Worksheet
   
    i = 35
    Set ws = ThisWorkbook.Sheets("Sheet1")
   
    For z = ws.Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        txt = ws.Range("A" & z).Value
        If Len(txt) > i Then
            For x = 1 To Len(txt) Step i
                ReDim Preserve var(y): var(y) = Mid(txt, x, i)
                y = y + 1
            Next x
            ws.Rows(z + 1 & ":" & z + UBound(var)).Insert
            ws.Range("A" & z).Resize(UBound(var) + 1, 1) = Application.Transpose(var)
            Erase var: y = 0
        End If
    Next z
End Sub

 

[Akuini]

Try this:

Sub azur3_1()
Dim i As Long, k As Long
Dim va, vb
va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
ReDim vb(1 To UBound(va, 1) * 3, 1 To 1) ' * 3 means I assume the result won't exceed 3 times the number of data rows, please, change to suit

For i = 1 To UBound(va, 1)
    tx = va(i, 1)
    Do
        If Len(tx) > 35 Then
            k = k + 1
            vb(k, 1) = Left(tx, 35)
            tx = Mid(tx, 36, 40000)
        End If
            
        If Len(tx) < 36 Then k = k + 1: vb(k, 1) = tx
    Loop While Len(tx) > 35
Next
'put the result
Range("C1").Resize(k, 1) = vb
End Sub

Book1
	A	B	C
1	1 Lorem ipsum dolor sit amet, consectetur adipiscing elit. In leo justo, scelerisque a consequat at,		1 Lorem ipsum dolor sit amet, conse
2	.		ctetur adipiscing elit. In leo just
3	2 Sed efficitur accumsan ante, tincidunt tempor lacus accumsan nec		o, scelerisque a consequat at,
4	.		.
5	3 Morbi ipsum		2 Sed efficitur accumsan ante, tinc
6	.		idunt tempor lacus accumsan nec
7	4. Aliquam blandit fermentum lacus ut malesuada. Praesent pretium ex nec mi fringilla dignissim		.
8			3 Morbi ipsum
9			.
10			4. Aliquam blandit fermentum lacus
11			ut malesuada. Praesent pretium ex n
12			ec mi fringilla dignissim
Sheet2

 

[azur3]

Here is what I was playing with:

Sub test()
    Dim txt As String, var() As Variant
    Dim i As Long, x As Long, y As Long, z As Long
    Dim ws As Worksheet
   
    i = 35
    Set ws = ThisWorkbook.Sheets("Sheet1")
   
    For z = ws.Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        txt = ws.Range("A" & z).Value
        If Len(txt) > i Then
            For x = 1 To Len(txt) Step i
                ReDim Preserve var(y): var(y) = Mid(txt, x, i)
                y = y + 1
            Next x
            ws.Rows(z).Delete
            ws.Rows(z & ":" & z + UBound(var)).Insert
            ws.Range("A" & z).Resize(UBound(var) + 1, 1) = Application.Transpose(var)
            Erase var: y = 0
        End If
    Next z
End Sub

Try this:

Sub azur3_1()
Dim i As Long, k As Long
Dim va, vb
va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
ReDim vb(1 To UBound(va, 1) * 3, 1 To 1) ' * 3 means I assume the result won't exceed 3 times the number of data rows, please, change to suit

For i = 1 To UBound(va, 1)
    tx = va(i, 1)
    Do
        If Len(tx) > 35 Then
            k = k + 1
            vb(k, 1) = Left(tx, 35)
            tx = Mid(tx, 36, 40000)
        End If
           
        If Len(tx) < 36 Then k = k + 1: vb(k, 1) = tx
    Loop While Len(tx) > 35
Next
'put the result
Range("C1").Resize(k, 1) = vb
End Sub

Book1
	A	B	C
1	1 Lorem ipsum dolor sit amet, consectetur adipiscing elit. In leo justo, scelerisque a consequat at,		1 Lorem ipsum dolor sit amet, conse
2	.		ctetur adipiscing elit. In leo just
3	2 Sed efficitur accumsan ante, tincidunt tempor lacus accumsan nec		o, scelerisque a consequat at,
4	.		.
5	3 Morbi ipsum		2 Sed efficitur accumsan ante, tinc
6	.		idunt tempor lacus accumsan nec
7	4. Aliquam blandit fermentum lacus ut malesuada. Praesent pretium ex nec mi fringilla dignissim		.
8			3 Morbi ipsum
9			.
10			4. Aliquam blandit fermentum lacus
11			ut malesuada. Praesent pretium ex n
12			ec mi fringilla dignissim
Sheet2

Both work splendidly, you guys are wizards.

Thanks a lot!

 

[Georgiboy]

Glad we could help.

I did update my code in my original post to remove the need for deleting the row, it will be faster that way.