Break up info in 1 cell to multiple cells on another worksheet

[Andrewryan3]

I need to break up/spread out the information from cell J in worksheet #1 to cells CS through CX on worksheet #2. The information in cell J is similar to the following:

'For resolution unit 6/5/17 regarding activation fees for video group plus, Brandon PLUS negotiated savings $24,272.66 and fee billing is 21% below market and fee schedule savings'

Each cell in CS-CX can hold up to 100 characters (including spaces). The information in 'J' varies at any given time, so I am clueless where to even start

Thanks

 

[Andrewryan3]

Two possibilities... one, your text has Line Feeds in it or, two, it has multiple adjacent spaces in it. This modification to my code should handle these problems... let me know if it works or not.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, TextMax As String, SplitText As String
  Dim Space As Long, MaxChars As Long, CellWithText As Range
  MaxChars = 100
  For Each CellWithText In Sheets("Sheet1").Range("J1", Sheets("Sheet1").Cells(Rows.Count, "J").End(xlUp))
    Text = Application.Trim(Replace(CellWithText.Value, vbLf, " "))
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      If Right(TextMax, 1) = " " Then
        SplitText = SplitText & RTrim(TextMax) & vbLf
        Text = Mid(Text, MaxChars + 2)
      Else
        Space = InStrRev(TextMax, " ")
        If Space = 0 Then
          SplitText = SplitText & Left(Text, MaxChars) & vbLf
          Text = Mid(Text, MaxChars + 1)
        Else
          SplitText = SplitText & Left(TextMax, Space - 1) & vbLf
          Text = Mid(Text, Space + 1)
        End If
      End If
    Loop
    Sheets("Sheet2").Cells(CellWithText.Row, "CS").Value = SplitText & Text
  Next
  Sheets("Sheet2").Columns("CS").TextToColumns , xlDelimited, , True, False, False, False, False, True, vbLf
  Sheets("Sheet2").UsedRange.SpecialCells(xlBlanks).Delete xlShiftToLeft
End Sub
[/TD]
[/TR]
</tbody>[/TABLE]

Rick,
This starts than asks if I want to replace the information already populated in the cells, but then it moves all the information to AH and deletes all info back to that point....very weird

 

[Roderick_E]

Formulaic....
In CS =IF(LEN($J2)<=16,$J2,LEFT($J2,16))
In CT =IF(LEN($J2)<=16,"",MID($J2,17,16))
In CU =IF(LEN($J2)<=16,"",MID($J2,32,16))
In CV =IF(LEN($J2)<=16,"",MID($J2,47,16))
In CW =IF(LEN($J2)<=16,"",MID($J2,62,17))
In CX =IF(LEN($J2)<=16,"",MID($J2,77,19))

Splits up J into 16 string segments up to 100 characters, except CW and CX which could be 17 and 19 characters respectively.

 

[Rick Rothstein]

Rick,
This starts than asks if I want to replace the information already populated in the cells, but then it moves all the information to AH and deletes all info back to that point....very weird

Sorry, my fault... I made a couple of bad assumptions about Sheet2. See if this works correctly...

[table="width: 500"]
[tr]
	[td]Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, TextMax As String, SplitText As String
  Dim Space As Long, MaxChars As Long, CellWithText As Range
  MaxChars = 100
  Sheets("Sheet2").Range("CS1:CX" & Sheets("Sheet2").Cells(Rows.Count, "CS").End(xlUp).Row).ClearContents
  For Each CellWithText In Sheets("Sheet1").Range("J1", Sheets("Sheet1").Cells(Rows.Count, "J").End(xlUp))
    Text = Application.Trim(Replace(CellWithText.Value, vbLf, " "))
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      If Right(TextMax, 1) = " " Then
        SplitText = SplitText & RTrim(TextMax) & vbLf
        Text = Mid(Text, MaxChars + 2)
      Else
        Space = InStrRev(TextMax, " ")
        If Space = 0 Then
          SplitText = SplitText & Left(Text, MaxChars) & vbLf
          Text = Mid(Text, MaxChars + 1)
        Else
          SplitText = SplitText & Left(TextMax, Space - 1) & vbLf
          Text = Mid(Text, Space + 1)
        End If
      End If
    Loop
    Sheets("Sheet2").Cells(CellWithText.Row, "CS").Value = SplitText & Text
  Next
  Sheets("Sheet2").Columns("CS").TextToColumns , xlDelimited, , True, False, False, False, False, True, vbLf
  Sheets("Sheet2").Range("CS1:CX" & Sheets("Sheet2").Cells(Rows.Count, "CS").End(xlUp).Row).SpecialCells(xlBlanks).Delete xlShiftToLeft
End Sub[/td]
[/tr]
[/table]

 

[Andrewryan3]

Formulaic....
In CS =IF(LEN($J2)<=16,$J2,LEFT($J2,16))
In CT =IF(LEN($J2)<=16,"",MID($J2,17,16))
In CU =IF(LEN($J2)<=16,"",MID($J2,32,16))
In CV =IF(LEN($J2)<=16,"",MID($J2,47,16))
In CW =IF(LEN($J2)<=16,"",MID($J2,62,17))
In CX =IF(LEN($J2)<=16,"",MID($J2,77,19))

Splits up J into 16 string segments up to 100 characters, except CW and CX which could be 17 and 19 characters respectively.

Rick this seems like it would work, but what if the info in call J1 is 180 characters? this will not work

 

[Roderick_E]

Rick this seems like it would work, but what if the info in call J1 is 180 characters? this will not work

What do you want to do if it's more than 100? You told us the 6 columns would only hold up to 100 characters

 

[Andrewryan3]

What do you want to do if it's more than 100? You told us the 6 columns would only hold up to 100 characters

I am sorry if I was confusing. What I said was, "The information does vary, yes. I simply need whole words in each of the columns and it can be up to 100." meaning 100 characters in each of the columns up to 100.

 

[Rick Rothstein]

I am sorry if I was confusing. What I said was, "The information does vary, yes. I simply need whole words in each of the columns and it can be up to 100." meaning 100 characters in each of the columns up to 100.

Did you get a chance to try the new code I posted in Message #13 yet?

 

[Andrewryan3]

Did you get a chance to try the new code I posted in Message #13 yet?

Rick, good morning!
I tested this on a cell that had 25 characters. This worked well, however it put 85 characters in the first column, 100 in the second and 25 in the 3rd. Is there a way to evenly distribute the info? I am just wondering since this prints on a receipt for the customer and my boss has asked to make it look more uniform. Thank you very much for what you have already done. I think you are amazing.

 

[Andrewryan3]

Did you get a chance to try the new code I posted in Message #13 yet?

It also deletes my headers. I tried to modify the VBA to start on CS3:CX, but it still deletes them. Any thoughts

 

[Roderick_E]

I am sorry if I was confusing. What I said was, "The information does vary, yes. I simply need whole words in each of the columns and it can be up to 100." meaning 100 characters in each of the columns up to 100.

So total maximum of 6 columns = 600 potential characters?, max 100 characters per column?
Do you simply want the string from column J to be spread evenly over the 6 columns? If so, what is the minimum string length you want in each column? CS-CX?
Let's assume 20 is the minimum

In CS =IF(LEN($J2)<=20,$J2,LEFT($J2,MAX(20,LEN($J2)/600)))
In CT =IF(LEN($J2)<=20,"",MID($J2,LEN($CS2)+1,MAX(20,LEN($J2)/600)))
In CU dragover to CX =IF(LEN($J2)<=20,"",MID(CT2,LEN(CT2)+1,MAX(20,LEN($J2)/600)))

This will put minimum 20 characters in each column until J-string distributed across CS-CX and maximum 100.