Split String into 2 Columns by 40 characters and 800 characters, Whole Word

[j9ortiz]

I have 90-120 character strings in Column A. I need Column B to take the first 40 whole word characters and Column C to take the remaining characters up to 800.

I have been researching a solution to this problem and everything I have seen has been slightly off from what I am looking for. I am trying to do this in VBA to stream line the process because I have 30 Spreadsheets each with over 1500 lines.

Example of what I need:

Column A: Original Message	Column B: First 40 Characters	Column C: Remaining Characters	Len (A)	Len (B)	Len (C )
Thank you for registering at the MrExcel Message Board. Before we can activate your account one last step.	Thank you for registering at the MrExcel	Message Board. Before we can activate your account one last step.	106	40	65
Please be sure not to add extra spaces. You will need to type in your username and activation number on the page.	Please be sure not to add extra spaces.	You will need to type in your username and activation number on the page.	113	40	73

<tbody>
</tbody>

 

[mumps]

This macro will loop through all your sheets. If there are any sheets in your workbook that you want to exclude, the macro will have to be modified. If this is the case, what are the names of the sheets you want to exclude?

Sub SplitString()
    Application.ScreenUpdating = False
    Dim rng As Range
    Dim LastRow As Long
    Dim ws As Worksheet
    For Each ws In Sheets
        LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For Each rng In ws.Range("A1:A" & LastRow)
            ws.Range("B" & rng.Row) = Left(rng, 40)
            ws.Range("C" & rng.Row) = Mid(rng, 41, 800)
        Next rng
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[j9ortiz]

Thank you for responding! So I ran this macro and it seems to be cutting some of the words in half. Is there a way to cut it off on a whole word before 40 characters?

 

[mumps]

Give this a try:

Sub SplitString()
    Application.ScreenUpdating = False
    Dim count As Long
    Dim rng As Range
    Dim LastRow As Long
    Dim ws As Worksheet
    For Each ws In Sheets
        LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For Each rng In ws.Range("A1:A" & LastRow)
            If Mid(rng, 41, 1) <> " " Then
                count = InStrRev(rng, " ", 41)
                ws.Range("B" & rng.Row) = Left(rng, count - 1)
                ws.Range("C" & rng.Row) = Mid(rng, count + 1, 800)
            Else
                ws.Range("B" & rng.Row) = Left(rng, 40)
                ws.Range("C" & rng.Row) = Mid(rng, 41, 800)
            End If
        Next rng
    Next ws
    Application.ScreenUpdating = True
End Sub