How to Delimit without Splitting Words (Text to Columns) ?

[jrocco]

In the attached sample file, I need to separate Column B (Asset Description)into 3 columns. The maximum number of characters per column is 43 characters. However, it is important that no words are split down the middle. If the original data is less than 43 characters to begin with, it can remain in one column. A Space between words can be used to judge the definition of a "complete word", but traditional Text To Columns doesn't work because it doesn't recognize character count.

This is a sample with a 4 lines of data, but my actual data file is over 900 so it is impractical to perform manually.

Any ideas?

[TABLE="class: grid, width: 800"]
<tbody>[TR]
[TD]Asset Number[/TD]
[TD]Asset Description[/TD]
[/TR]
[TR]
[TD]EXCONTVCAT 0692[/TD]
[TD]692 CAT DOZER MODEL 973; SERIAL/VIN# 973CELDX00452; OWNED; YR 2009[/TD]
[/TR]
[TR]
[TD]EXCONTVCRLOAD 0691[/TD]
[TD]691 CATERPILLER LOADER S/N CAT0973CHBCPOO194 M# 973C YR 2005 OWNED[/TD]
[/TR]
[TR]
[TD]EXCONTVGRADALL 0618[/TD]
[TD]618 TRACK GRADALL S/N 5210000840 MODEL XL5210[/TD]
[/TR]
[TR]
[TD]EXCONTVKOMATSU 0681[/TD]
[TD]681 KOMATSU 6 WAY BLADE DOZER[/TD]
[/TR]
</tbody>[/TABLE]

 

[mikerickson]

Perhaps this

Sub test()
    Dim Result() As String
    Dim strRaw As String, RawWords As Variant
    Dim i As Long, j As Long, Pointer As Long
    Dim strResult As String
    Dim DataRange As Range
    With Sheet1.Range("B:B")
        Set DataRange = Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
    End With
    ReDim Result(1 To DataRange.Rows.Count, 1 To 4)
    
    For i = 1 To DataRange.Rows.Count
        strRaw = DataRange.Cells(i, 1).Value
        If strRaw <> vbNullString Then
            RawWords = Split(strRaw, " ")
            
            Pointer = 0: j = 1
            strResult = RawWords(Pointer)
            Pointer = Pointer + 1
            Do
                If Len(strResult & " " & RawWords(Pointer)) > 43 Then
                    Rem put result in array
                    Result(i, j) = strResult
                    j = j + 1
                    strResult = RawWords(Pointer)
                    Pointer = Pointer + 1
                Else
                    strResult = strResult & " " & RawWords(Pointer)
                    Pointer = Pointer + 1
                End If
            Loop Until UBound(RawWords) < Pointer
            If j < 5 Then Result(i, j) = strResult
        End If
    Next i
    DataRange.Offset(0, 2).Resize(, 4).Value = Result
End Sub

 

[njimack]

This probably won't work for your 900+rows but should point you in the right direction. I had to guess at a character that doesn't appear in any of the descriptions. I've used @ but you might need to change to something else
C2

=IF(LEN(B2)<=43,B2,LEFT(B2,FIND("@",SUBSTITUTE(B2," ","@",LEN(LEFT(B2,43))-LEN(SUBSTITUTE(LEFT(B2,43)," ",""))))))

D2

=IF(LEN(B2)-LEN(C2)<=43,SUBSTITUTE(B2,C2,""),LEFT(MID(B2,LEN(C2)+1,43),FIND("@",SUBSTITUTE(MID(B2,LEN(C2)+1,43)," ","@",LEN(LEFT(MID(B2,LEN(C2)+1,43),43))-LEN(SUBSTITUTE(LEFT(MID(B2,LEN(C2)+1,43),43)," ",""))))))

E2

=IF(LEN(B2)-LEN(C2)-LEN(D2)<=43,SUBSTITUTE(B2,C2&D2,""),LEFT(MID(B2,LEN(C2)+LEN(D2)+1,43),FIND("@",SUBSTITUTE(MID(B2,LEN(C2)+LEN(D2)+1,43)," ","@",LEN(LEFT(MID(B2,LEN(C2)+LEN(D2)+1,43),43))-LEN(SUBSTITUTE(LEFT(MID(B2,LEN(C2)+LEN(D2)+1,43),43)," ",""))))))

 

[jrocco]

Thanks, Neil. This worked beautifully!