Divide the cell content into separate rows along w

Question

I am trying to split the cell content with length greater than 72 into separate rows with their length not increasing more than 72 chars. But I was trying to do how can I repeat the serial number for each cell while dividing them into 72 chars. For example if I have a cell with 144 chars and serial number S1 assigned to it in another column, so when I use the above module to divide the text into 2 cells then the same Serial number S1 is also copied to each new cell created. Can we do it? Code is as below;

Any suggestions?

Link to code

Thanks

Answer 1

Now that you have provided examples of your input data and desired output, here is one way to accomplish that, modifying the storage routines in the previously provided code.

Since one cannot Redim Preserve an array changing the size of the first dimension, we use a Collection object to collect all the individual lines, and then size and populate the results array in a separate step.

Some assumptions are that the source data is on sheet1 columns A:C with column headers in row 1, and that the results will be written on sheet2.

Go through the code and understand what is going on at each step. Ask question to clarify as to why something is done one way vs another.

---

Option Explicit
Sub WordWrap2()
'requires reference to Microsoft VBScript Regular Expressions 5.5
'Wraps at W characters, but will allow overflow if a word is longer than W
Dim RE As RegExp, MC As MatchCollection, M As Match
Dim str As String
Const W As Long = 72

Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant
Dim vRes() As Variant 'Results
Dim colLines As Collection
Dim vLine(1 To 3) As Variant 'to store each line in collection
Dim I As Long

'Set source to column A:C
'  A = Sequence
'  B = ID
'  C = TXLINE2
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Range("A1", .Cells(.Rows.Count, "C").End(xlUp))
End With

Set RE = New RegExp
    RE.Global = True

    'Cycle through third column only, and collect the data
    Set colLines = New Collection
    For I = 1 To UBound(vSrc, 1)
        str = vSrc(I, 3)

        'remove all line feeds and nbsp
        RE.Pattern = "[\xA0\r\n\s]+"
        str = RE.Replace(str, " ")
        RE.Pattern = "\S.{0," & W - 1 & "}(?=\s|$)|\S{" & W & ",}"

        If RE.Test(str) = True Then
            Set MC = RE.Execute(str)

            'Collect the lines, along with Seq and ID
            For Each M In MC
                vLine(1) = vSrc(I, 1)
                vLine(2) = vSrc(I, 2)
                vLine(3) = M
                colLines.Add vLine
            Next M
        Else  'Allow preservation of blank lines in source data
            Erase vLine
            colLines.Add vLine
    End If
Next I

'create results array
ReDim vRes(1 To colLines.Count, 1 To 3)

'Note that column headers are carried over from source data

'Populate with the data
For I = 1 To colLines.Count
    vRes(I, 1) = colLines(I)(1)
    vRes(I, 2) = colLines(I)(2)
    vRes(I, 3) = colLines(I)(3)
Next I

Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

Set RE = Nothing
End Sub

---

Before:

After:

Answer 2

One simple method would be to create a range that increments as the new cells are added, and then after all of the new cells have been created, run through the range and append the serial number as appropriate. So, assuming the serial number is in Cells(1,2) (though this can be easily adjusted), add this to the original processing loop.

Dim finalRange As Range
Set finalRange = ActiveSheet.Range(Cells(1,2).Address)

'Now inside the loop:
Set finalRange = Union(finalRange,newCellLocation) ' where newCellLocation is where the next line of characters has been placed

'After the loop is complete
For Each cell In finalRange
If cell.Address <> ActiveSheet.Cells(1,2).Address Then
cell.value = ActiveSheet.cells(1,2).Value & ": " & cell.Value
'Note, adjust the string values to your desired format, this is just a placeholder
End If
Next Cell