Truncate but keep full words using VBA?

[razzandy]

Hi Guys

Happy Halloween! ?‍?‍ ??

I have produced the below code to look at cell data to check if the contents is not above 100 characters. If it is, it removes everything above 100 and places it in the next column with the current data already in that cell. Then later, it will check that cell containing old and new data to also see if contents are above 100 characters and so on until last column is complete. This works fine but I am struggling to retain 'whole words' because I don't want part of a word cutting in half so to speak! If the cut happens within a word I need it to remove the whole word and transfer it to the next column as above. Hope this makes sense.

For Each cell In rng
Dim Orders As Worksheet: Set Orders = Sheets("Orders")
Dim LstCol As Long: LstCol = Orders.Range("a1").CurrentRegion.Columns.Count
Dim LstRW As Long: LstRW = Orders.Range("a1").CurrentRegion.Rows.Count
Dim rng As Range: Set rng = Orders.Range("M2:M" & LstRW & ",O2:O" & LstRW & " ,P2:P" & LstRW)
Dim cell As Range
Dim AddressField As String
Dim AFCLength As Integer



If cell.Address = "$O$2" Then Stop
    AFCLength = _
    Len(cell.Value & cell.Offset(, 2).Value2 & cell.Offset(, 3).Value2)
        
        AddressField = cell.Value2
        If Len(AddressField) > 100 Then

            Sheets("Royal Mail").Range("j" & cell.Row + 2).Offset(, 4).Value2 = _
            LTrim(Right(AddressField, Len(AddressField) - Len(Left(AddressField, 100)))) & ", " & cell.Offset(, 2).Value2

            Sheets("Royal Mail").Range("j" & cell.Row + 2).Value2 = Left(AddressField, 100)
            
        End If
Next

 

[mikerickson]

This should do what you want.

Sub TidySizeCells(startCell As Range, Optional MaxLength As Long = 100, Optional OverflowDirection = xlToRight, Optional PutIn As Range)
    Dim i As Long
    Dim strContents As String, Words As Variant, nextBit As String
    Dim WriteString As String
   
    If PutIn Is Nothing Then Set PutIn = startCell.Cells(1, 1)
   
    strContents = CStr(startCell.Cells(1, 1).Value)
    strContents = Replace(strContents, vbCr, vbLf)
    strContents = Replace(strContents, vbLf, vbLf & " ")
    strContents = WorksheetFunction.Trim(strContents)
    Words = Split(strContents, " ")
   
    For i = 0 To UBound(Words)
        nextBit = Words(i)
        If MaxLength < Len(WriteString & " " & nextBit) Then
            Rem write to sheet
            If WriteString = vbNullString Then
                WriteString = nextBit
                strContents = Replace(strContents, nextBit, vbNullString, Count:=1)
            End If
            Exit For
        Else
            WriteString = WriteString & " " & nextBit
            strContents = Replace(strContents, nextBit, vbNullString, Count:=1)
        End If
    Next i
    strContents = Trim(strContents)
    PutIn.Value = "'" & WriteString
    If strContents <> vbNullString Then
        Select Case OverflowDirection
            Case xlDown
                Set PutIn = PutIn.Offset(1, 0)
            Case xlToLeft
                Set PutIn = PutIn.Offset(0, -1)
            Case xlToRight
                Set PutIn = PutIn.Offset(0, 1)
            Case xlUp
                Set PutIn = PutIn.Offset(-1, 0)
        End Select
        PutIn.Value = strContents
        Call TidySizeCells(PutIn, MaxLength, OverflowDirection, PutIn)
    End If
End Sub

Call TidySizeCells(Range("A1")) will parse the string in A1 into words (not characters) where the total length is <= 100. Overflow will be spread to the right (also with the 100 character limit).
The MaxLength (default 100) and the direction of overflow (default xlToRight) can be specified, as can the cell where the divided contents are put.

 

[razzandy]

That looks great @mikerickson I will integrate and test then get back to you.


Thanks Very Much

 

[razzandy]

That looks great @mikerickson I will integrate and test then get back to you.


Thanks Very Much

This code is above my level of expertise but its taught me a lot so thankyou @mikerickson

I have tested it and I can work out what its doing but it seems when it passes the word(s) over into the next cell it's erasing the contents of that cell instead of placing the word(s) in front of what is already in that cell.

The range in my code is set for Columns M, O & P (It Jumps Col N cause this is a phone number) and it loops through those cells in that range passing any overflow into the next column. So if overflow is from M2 its added into O2 and if overflow is from O2 it overflows into P2 making sure the max character length is not exceeded and all original text entered is retained but spread across the columns M, O & P. I suppose there could be a situation (hopefully not!) that all 3 Cells in each column exceeds a 100 each so in that situation it must not overflow anymore or add a column because this would be acceptable but one more column is the max?

This is basically checking address fields do not exceed 100 characters in each field/cell. Rather than just truncate and delete the overflow I want it to be added to the next address fields so the complete address from all 3 fields is retained but spread across all the available fields. I do intend sending the data to another sheet where the output CSV sheet gets built and on that sheet I can have 1 more address field/column. That's because the address fields in the received file are less than the fields in my output file. So lets say my received file exceeded 100 each in 3 Columns then it could overflow into the 4th column by adding an extra column?

Thanks Again

 

[mikerickson]

If you want the extra to be added to the next cell change the fourth to last line in the code.

PutIn.Value = PutIn.Value & " " &strContents