Parse Text, Split to New Row, Multiple Columns

Hi All,

I'm in a sticky situation regarding parsing text according to column width.

I've attached a sample worksheet with very fake data. And I'll post the code below.

But for an overview of my conundrum:
- My users create spreadsheets with many many text fields. The final product has to have columns of a certain width.
- Users (in the past) have manual had to figure out, cell by cell, where to break the text near the column edge, copy all the cell contents, insert a row, and then paste and indent the remainder of the text.

So, in review, there might be a few sentences in one column (let's say column E) with some identifying data in col A. Each string must fit within the column width, and if the string is larger than one cell's width, the text must go onto a new row below, and be indented. This is repeated until a new record is reached, when the process begins again.

My problem:
I'm using code that more or less works the way I need it to, but only on one column at a time.

I need to figure out a looping structure to have it:
(1) - For each column in row 1, specify the fixed width
(2) - Go column by column in row one to find strings greater than the width. Cut the string beyond the column width.
(3) - Insert a new row below, paste the string in the appropriate column.
(4) - Loop until worksheet is done.

Here's the code, and again, I've attached a sample with very fake text data.
Thanks for any ideas on this horrendous problem!

Option Explicit
'Default ratio for splitting; adjust to suit font size
Public Const Ratioa = 0.25
Public Const Ratioc = 0.19
Public Const Ratioe = 0.26
Public Const Ratiog = 0.26
Public Const Ratioi = 0.22

Sub Test()

    Dim MyText As String
    Dim WrapLengtha As Long
    Dim WrapLengthc As Long
    Dim WrapLengthe As Long
    Dim WrapLengthg As Long
    Dim WrapLengthi As Long
    Dim StrLen As Long
    Dim LastRow As Long
    Dim LastCol As Integer
    Dim x As Integer
    Dim J As Long
    
'Change Column Widths
    Rows("1:450").RowHeight = 12
    Columns("A:A").ColumnWidth = 16
    Columns("B:B").ColumnWidth = 1.5
    Columns("C:C").ColumnWidth = 10
    Columns("D:D").ColumnWidth = 1.5
    Columns("E:E").ColumnWidth = 40
    Columns("F:F").ColumnWidth = 1.5
    Columns("G:G").ColumnWidth = 34.5
    Columns("H:H").ColumnWidth = 1.5
    Columns("I:I").ColumnWidth = 15.5
    Columns("J:J").ColumnWidth = 1.5

'Set Cell at Beginning of Data
    Range("E1").Select
    
    WrapLengtha = Int(ActiveCell.Width) * Ratioa
    WrapLengthc = Int(ActiveCell.Width) * Ratioc
    WrapLengthe = Int(ActiveCell.Width) * Ratioe
    WrapLengthg = Int(ActiveCell.Width) * Ratiog
    WrapLengthi = Int(ActiveCell.Width) * Ratioi
    
    LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    LastCol = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
    
'Analyse text for space preceding cell width and split text
    For x = 1 To 9
         MyText = ActiveCell.Text
         StrLen = Len(MyText)
         If StrLen <= WrapLengtha Then
             ActiveCell.Offset(1, 0).Select
         ElseIf StrLen > WrapLengtha Then
             For J = WrapLengtha To 0 Step -1
                 If J = 0 Then Exit For
                 If Mid(MyText, J, 1) = " " Then
                     Selection.Offset(1, 0).EntireRow.Insert
                     Selection.Offset(1, 0).IndentLevel = 1
                     ActiveCell.Formula = Left(MyText, J)
                     ActiveCell.Offset(1, 0).Formula = Right(MyText, StrLen - J)
              Exit For
         End If
         Next
         ActiveCell.Offset(1, 0).Select
         End If
    Next
End Sub

Hi

See how this goes.

Sub aaa()
  Dim i As Long, j As Integer, resizelen As Integer, curlen As Integer
  resizelen = 1
  Columns("A:A").ColumnWidth = 12
  Columns("B:B").ColumnWidth = 1.5
  Columns("C:C").ColumnWidth = 10
  Columns("D:D").ColumnWidth = 1.5
  Columns("E:E").ColumnWidth = 46.5
  Columns("F:F").ColumnWidth = 1.5
  Columns("G:G").ColumnWidth = 34.5
  Columns("H:H").ColumnWidth = 1.5
  Columns("I:I").ColumnWidth = 15.5
  Columns("J:J").ColumnWidth = 1.5

  
  Application.DisplayAlerts = False
  For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
    Cells(i + 1, 1).Resize(resizelen, 1).EntireRow.Insert shift:=xlDown
    For j = 1 To 5
      
      curlen = Round(Len(Cells(i, j)) / Cells(i, j).ColumnWidth, 0)
      If curlen > resizelen Then
        Cells(i, 1).Offset(resizelen + 1, 0).Resize(curlen - resizelen, 1).EntireRow.Insert shift:=xlDown
        resizelen = curlen
      End If
      Cells(i, j).Justify
    Next j
  Next i
  Application.DisplayAlerts = True
  
  For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
    If IsEmpty(Cells(i, 1)) And Cells(i, 1).End(xlToRight).Column = Columns.Count Then 'ie it is a blank line
      Cells(i, 1).EntireRow.Delete
    End If
  Next i
End Sub

rylo

Hi msbaker;

I'm just curious. Why don't you just format the cells using wordwrap. Why do you have to insert a row for the continuation of the sentence?