CHARACTER LENGTH NEW CELL

[Hadorian]

Hello!
Is it possible that a text written in a cell that exceeda e.g. 40 characters splits into 2 or 3 cells when pressed Enter.
Meaning it would requirw text from e.g. cell A1 with 100 characters to split into A2 and A3 without breaking the words.
Maybe thwrw is some script for this.

Thank you

 

[JGordon11]

try this in the worksheet module

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    On Error GoTo ErrorHandler
    Const BreakPoint = 40
    If Len(Target) > BreakPoint Then
        Application.EnableEvents = False
        Dim a, os As Long, wd, CharCount As Long, partial As String
        a = Split(Target, " ")
        For Each wd In a
            CharCount = Len(wd) + 1 + CharCount
            If CharCount > BreakPoint Then
                If Len(partial) > 0 Then
                    Target.Offset(0, os) = Trim(partial)
                    os = os + 1
                End If
                partial = wd & " "
                CharCount = Len(partial)
            Else
                partial = partial & wd & " "
            End If
        Next
        Target.Offset(0, os) = Trim(partial)
    End If
ErrorHandler:
    Application.EnableEvents = True
End Sub

 

[Hadorian]

it does not work...it does nothing

 

[Peter_SSs]

it does not work...it does nothing

Perhaps you put the code in the wrong place?

However, I think that code sometimes does not put the full 40 characters in a cell when they would fit.

This is my version. To implement ..
1. Right click the sheet name tab and choose "View Code".
2. Copy and Paste the code below into the main right hand pane that opens at step 1.
3. Close the Visual Basic window & test.
4. Your workbook will need to be saved as a macro-enabled workbook (*.xlsm).

If you want to change the maximum number of characters per cell just edit the 'Const' line towards the start of the code.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim s As String
  Dim k As Long
  Dim result As Variant
 
  Const CharsPerCell As Long = 40     '<-Change to suit
 
  If Target.CountLarge = 1 Then
    s = Target.Text
    ReDim result(1 To Len(s) / CharsPerCell + 2, 1 To 1)
    k = 0
    Do Until Len(s) = 0
      k = k + 1
      result(k, 1) = RTrim(Left(s, InStrRev(s & Space(CharsPerCell), " ", CharsPerCell + 1) - 1))
      s = Mid(s, Len(result(k, 1)) + 2)
    Loop
    Application.EnableEvents = False
    Target.Offset(1).Resize(k).Value = result
    Application.EnableEvents = True
  End If
End Sub

Here is my sample after entering the text into cell D1. I have added the LEN functions in column E simply to check my results.

Hadorian.xlsm
	D	E
1	Lorem Ipsum is simply dummy text of theory printing and typesetting industry. Lorem Ipsum has been the industry's standard dummy text ever since the 1500s, when an unknown printer took a galley of type and scrambled it to make a type specimen book. It has survived not only five centuries, but also the leap into electronic typesetting, remaining essentially unchanged. It was popularised in the 1960s with the release of Letraset sheets containing Lorem Ipsum passages, and more recently with desktop publishing software like Aldus PageMaker including versions of Lorem Ipsum.
2	Lorem Ipsum is simply dummy text of	35
3	theory printing and typesetting	31
4	industry. Lorem Ipsum has been the	34
5	industry's standard dummy text ever	35
6	since the 1500s, when an unknown printer	40
7	took a galley of type and scrambled it	38
8	to make a type specimen book. It has	36
9	survived not only five centuries, but	37
10	also the leap into electronic	29
11	typesetting, remaining essentially	34
12	unchanged. It was popularised in the	36
13	1960s with the release of Letraset	34
14	sheets containing Lorem Ipsum passages,	39
15	and more recently with desktop	30
16	publishing software like Aldus PageMaker	40
17	including versions of Lorem Ipsum.	34
Sheet1

Cell Formulas
Range	Formula
E2:E17	E2	=LEN(D2)

 

[Hadorian]

It still doesn't work.
I followed everything and copied it exactly as you specified, but i get no results.
I am no expert. How to test it?

 

[Joe4]

It still doesn't work.
I followed everything and copied it exactly as you specified, but i get no results.
I am no expert. How to test it?

What is the name of the VBA module you are placing this in?
So you have VBA enabled on your workbook?

 

[Peter_SSs]

Also, how are you entering the value in the cell after the vba code has been entered as described?

 

[Hadorian]

 

[Peter_SSs]

That last post does not answer my question from post #7.

Nor does it answer the final question from @Joe4's post.

I am also unsure about the apparent multiple instances of the same VBAProject:

Have you tried closing right out of Excel and reopening with just this workbook and then entering (or re-entering) the text in a cell?

What is the text that you are entering and what cell is it in?

 

[Joe4]

jgordon's code seems to work for me, but I get an "Run-time error 5" on Peter's code on this line:

      result(k, 1) = RTrim(Left(s, InStrRev(s & Space(CharsPerCell), " ", CharsPerCell + 1) - 1))

but is at least trying to run the code.

One quick and easy way to make sure that the code is at least trying to run is to add a Message Box to the top of it, like this:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim s As String
  Dim k As Long
  Dim result As Variant
  
  MsgBox "VBA code running"
  ...

Then you should get that message box pop-up whenever the code is running.
If you aren't getting it, then something is wrong and it is not running it.

Please note: That all this code only runs on data that you are actively entering into cells!
It does NOT run on pre-existing data in your workbook!