Chop text in column to 60 charactersblocks

Question

I have a worksheet that has thousands of rows and only one column (A). The cells in column A can be null or up to and over 1000 characters. I need to run a macro that will loop through column A copying it to column B. If there are any cells that have any text > 60 characters to cut it into blocks of 60 into the next columns.

I have code that breaks text into blocks of 60 but I don't know how to get it to copy anything under 60, move to next row if null or loop through rows.

Sub x()
    Dim cLength As Long, cLoop As Long
    cLength = 60

    For cLoop = 1 To (Len([A2]) \ cLength) + 1
        [A2].Offset(, cLoop).Value = Mid([A2], ((cLoop - 1) * cLength) + 1, cLength)
    Next
End Sub

Answer 1

Try this. This should do your job:

    Sub pCopyTextToNextColumn()

        Dim wksSheet1           As Worksheet
        Dim rngColAData         As Range
        Dim rngCell             As Range
        Dim lngLastRow          As Long
        Dim cLoop As Long

        'Set the length
        cLength = 60

        'Assign worksheet
        Set wksSheet1 = Worksheets("Sheet1")
        'find last Row in column A
        lngLastRow = wksSheet1.Cells(wksSheet1.Rows.Count, 1).End(xlUp).Row

        'Set Data range
        With wksSheet1
            Set rngColAData = .Range(.Cells(1, 1), .Cells(lngLastRow, 1))
        End With

        'Loop through each cell in column A, and
        For Each rngCell In rngColAData.Cells
            'Length of the string is greater than 60 then loop through
            If Len(Trim(rngCell)) > cLength Then

                For cLoop = 1 To (Len(rngCell) \ cLength) + 1
                    rngCell.Offset(, cLoop).Value = Mid(rngCell, ((cLoop - 1) * cLength) + 1, cLength)
                Next

            Else
            'Else just paste the data in column B
                rngCell.Offset(, 1) = rngCell.Value

            End If

        Next rngCell

        'Release Memory
        Set wksSheet1 = Nothing
        Set rngColAData = Nothing
        Set rngCell = Nothing

    End Sub

Answer 2

Modified your code to make it generic for all rows:

Sub x()
    Dim cLength As Long
    Dim cLoop As Long
    Dim i As Long

    cLength = 60
    i = 1

    While i < 1001
        For cLoop = 1 To (Len(Cells(i, 1)) \ cLength) + 1
            Cells(i, cLoop + 1).Value = Mid(Cells(i, 1), ((cLoop - 1) * cLength) + 1, cLength)
        Next
        i = i + 1
    Wend
End Sub

Answer 3

Fastest way to handle it! (Uses no Loops. Processes the entire column in one go)

This uses the inbuilt Data | Text To Columns. We are using Fixed Width to split the data. The below code will handle strings up to 1320 characters in length.

Sub Sample()
    Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets("Sheet1")

    ws.Columns(1).TextToColumns _
        Destination:=Range("A1"), _
        DataType:=xlFixedWidth, _
        FieldInfo:=Array( _
                        Array(0, 1), Array(60, 1), Array(120, 1), Array(180, 1), _
                        Array(240, 1), Array(300, 1), Array(360, 1), Array(420, 1), _
                        Array(480, 1), Array(540, 1), Array(600, 1), Array(660, 1), _
                        Array(720, 1), Array(780, 1), Array(840, 1), Array(900, 1), _
                        Array(960, 1), Array(1020, 1), Array(1080, 1), Array(1140, 1), _
                        Array(1200, 1), Array(1260, 1), Array(1320, 1) _
                         ), _
        TrailingMinusNumbers:=True
End Sub

If you were to do it manually then you would be doing this.