Preventing WrapText With Character Limit from changing text to date format

[Jeremy4110]

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Part #
[/TD]
[TD]Original Description
[/TD]
[TD]Description1
[/TD]
[TD]Description 2
[/TD]
[TD]Description 2 Correction
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]I NEED TO TEST IT 52303 THREADED ROD 7/16-14
[/TD]
[TD]I NEED TO TEST IT 52303 THREADED ROD
[/TD]
[TD]7/16/2014
[/TD]
[TD]7/16-14
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]I NEED TO TEST IT 52300 THREADED ROD 1/4-20
[/TD]
[TD]I NEED TO TEST IT 52303 THREADED ROD
[/TD]
[TD]1/4/2020
[/TD]
[TD]1/4-20
[/TD]
[/TR]
</tbody>[/TABLE]











Hi,

I came across the code below which works, sort of. The issue I am having is that it changes my "TEXT" to a "DATE" when it separates the data into the second column. Does anyone have a fix that ensures that all cells remain in "TEXT" format?

Sub Description_WrapText_With_Character_Limit()

    Dim Text As String, TextMax As String, SplitText As String
    Dim Space As Long, MaxChars As Long
    Dim Source As Range, CellWithText As Range
  
    ' With offset as 1, split data will be adjacent to original data
    ' With offset = 0, split data will replace original data
    Const DestinationOffset As Long = 1
    MaxChars = 40 'Application.InputBox("Maximum number of characters per line?", Type:=1)
    Set Source = Range("B1", Cells(Rows.Count, "B").End(xlUp))
    For Each CellWithText In Source
        Text = CellWithText.Value
        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
        CellWithText.Offset(, DestinationOffset).Value = SplitText & Text
    Next
    Columns("C").TextToColumns Range("C1"), xlDelimited, , , False, False, False, False, True, vbLf
    Exit Sub
NoCellsSelected:
End Sub

Thanks,
Jeremy

 

[Rick Rothstein]

Re: Need help preventing WrapText With Character Limit from changing text to date format

Does this macro do what you want...

[table="width: 500"]
[tr]
	[td]Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, TextMax As String, SplitText As String, Space As Long, MaxChars As Long, Source As Range, CellWithText As Range
  Const DestinationOffset As Long = 1
  MaxChars = 40
  Set Source = Range("B2", Cells(Rows.Count, "B").End(xlUp))
  For Each CellWithText In Source
    Text = CellWithText.Value
    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
    CellWithText.Offset(, DestinationOffset).Value = SplitText & Text
  Next
  Source.Offset(, DestinationOffset).TextToColumns , xlDelimited, , , False, False, False, False, True, Chr(10), FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), Array(9, 2), Array(10, 2))
  Source.EntireRow.AutoFit
End Sub[/td]
[/tr]
[/table]

 

[Peter_SSs]

Re: Need help preventing WrapText With Character Limit from changing text to date format

Thanks for the additional sample data. My understanding is that you want the sizes to be reported in a separate cell on each row but from your samples those sizes do not need to all be in the same column. Is that correct?
If so, try this version. It has two main differences to the other recent suggestions
a. It puts the size in its own column on each row.
b. It is much faster (10x?) than the other codes and that may be relevant to you since you have of the order of 80,000 rows to process.

Anyway, give it a try in a copy of your workbook.

(If the sizes would be better all in a single column then we can easily modify the code to do that.)

Sub BreakEmUp()
  Dim sDesc As String, sSize As String
  Dim i As Long, j As Long, k As Long
  Dim a As Variant, b As Variant

  Const CharsPerLine As Long = 40     '<-Change to suit
  
  With Range("B2", Range("B" & Rows.Count).End(xlUp))
    a = .Value
    ReDim b(1 To UBound(a), 1 To 2)
    For i = 1 To UBound(a)
      sDesc = a(i, 1)
      sDesc = Left(sDesc, InStrRev(sDesc, " ") - 1)
      sSize = Mid(a(i, 1), Len(sDesc) + 2)
      k = 0
      If (Len(sDesc) / CharsPerLine + 2) > UBound(b, 2) Then ReDim Preserve b(1 To UBound(b), 1 To Len(sDesc) / CharsPerLine + 2)
      Do Until Len(sDesc) = 0
        k = k + 1
        b(i, k) = RTrim(Left(sDesc, InStrRev(sDesc & Space(CharsPerLine), " ", CharsPerLine + 1) - 1))
        sDesc = Mid(sDesc, Len(b(i, k)) + 2)
      Loop
      b(i, k + 1) = sSize
    Next i
    With .Offset(, 1).Resize(, UBound(b, 2))
      .NumberFormat = "@"
      .Value = b
      .Columns.AutoFit
    End With
  End With
End Sub

 

[Rick Rothstein]

Re: Need help preventing WrapText With Character Limit from changing text to date format

If so, try this version. It has two main differences to the other recent suggestions
a. It puts the size in its own column on each row.
b. It is much faster (10x?) than the other codes and that may be relevant to you since you have of the order of 80,000 rows to process.

I am not 100% sure what you mean by item (a), so my code below does not do that; however, I did rework the code and it is much, much faster than what I posted earlier... it might even be faster than your code now, a quick test on my computer seems to indicate that (but if I remember correctly, we differed on speed differences in the past because of differences in our computers, so if you test my code, you might not get the same result I did).

Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim X As Long, C As Long, Space As Long, MaxChars As Long
  Dim Text As String, TextMax As String, Arr As Variant
  Const DestinationOffset As Long = 1
  MaxChars = 40
  Arr = Range("B2", Cells(Rows.Count, "B").End(xlUp)).Resize(, 10)
  For X = 1 To UBound(Arr)
    Text = Arr(X, 1)
    C = 0
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      C = C + 1
      If Right(TextMax, 1) = " " Then
        Arr(X, C) = RTrim(TextMax)
        Text = Mid(Text, MaxChars + 2)
      Else
        Space = InStrRev(TextMax, " ")
        If Space = 0 Then
          Arr(X, C) = Left(Text, MaxChars)
          Text = Mid(Text, MaxChars + 1)
        Else
          Arr(X, C) = Left(TextMax, Space - 1)
          Text = Mid(Text, Space + 1)
        End If
      End If
    Loop
    C = C + 1
    Arr(X, C) = Text
  Next
  With Range("C2").Resize(UBound(Arr), 10)
    .NumberFormat = "@"
    .Value = Arr
  End With
End Sub

 

[Jeremy4110]

Re: Need help preventing WrapText With Character Limit from changing text to date format

Thank you

 

[Jeremy4110]

Re: Need help preventing WrapText With Character Limit from changing text to date format

Hi Yongle,

I formatted the columns C-G as text prior to running your last revision and it work PERFECTLY. Thank you so much for your help, you are AWESOME. I still have sooooo much to learn.


Thanks,
Jeremy

 

[Yongle]

Re: Need help preventing WrapText With Character Limit from changing text to date format

Glad it gave you what you needed.
It would be interesting to know how much faster Peter's & Rick's code are for you - did you test those too ?

 

[Jeremy4110]

Re: Need help preventing WrapText With Character Limit from changing text to date format

Hi Rick,

Thank you for you help. I hope you are doing well. You have a great memory, we did have speed differences in the past because of differences in our computers. Since then I have upgraded my laptop and you are correct, your last code is a lot faster and formats data that looks like a date but is a size to text.

Thanks,
Jeremy

 

[Jeremy4110]

Re: Need help preventing WrapText With Character Limit from changing text to date format

Hi Peter,

Thank you for helping me. Your code is super fast. It's not that I the sizes in their own column at the end of the row, its more like that just happens to be where they end in the examples because if there was a word or letter that preceded the size when it split at 40 characters it kept the text format, I assume because of the leading text (word or letter). It's only when the size was separated by its self that is converted to a date.


Thank you so much,
Jeremy

 

[Peter_SSs]

Re: Need help preventing WrapText With Character Limit from changing text to date format

Hi Peter,

Thank you for helping me. Your code is super fast.

You're welcome.

It's not that I the sizes in their own column at the end of the row, its more like that just happens to be where they end in the examples because if there was a word or letter that preceded the size when it split at 40 characters

I don't quite follow that, but would you prefer to have all the sizes in a single column at the right?

 

[Yongle]

Re: Need help preventing WrapText With Character Limit from changing text to date format

Jeremy

a faster version of my previous code

Sub Faster_Description_WrapText_With_Character_Limit()
    Application.ScreenUpdating = False
    Dim Text As String, TextMax As String, SplitText As String
    Dim Space As Long, MaxChars As Long
    Dim Source As Variant, Temp As Variant, Result As Variant
    Dim r As Long, c As Long, s As Long
  

    Const DestinationOffset As Long = 1
    MaxChars = 40 'Application.InputBox("Maximum number of characters per line?", Type:=1)
    Source = Range("B1", Cells(Rows.Count, "B").End(xlUp))
    s = UBound(Source)
    ReDim Result(1 To s, 1 To 15)
    
    For r = 1 To s
        Text = Source(r, 1)
        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
        Temp = Split(SplitText & Text, vbLf)
        For c = 0 To UBound(Temp)
            Result(r, c + 1) = Temp(c)
        Next
    Next r
    With Range("C1").Resize(s, 15)
        .NumberFormat = "@"
        .Value = Result
        .Columns.AutoFit
    End With

    Exit Sub
NoCellsSelected:
End Sub