VBA: Separate cell text to one word per line

[DarkJester89]

Can anybody suggest a way, VBA to apply to a range of cells into one row (B2:CT2) so it's one word per line (in the same cell).

I have a code that extends the column out but it pushes all the text to one line, so it's too long.

Sub AutoFitWrappedText()
    With Range("B2:CT2").EntireColumn
    .ColumnWidth = 255 ' maximum width
    .AutoFit
    End With
End Sub

Example Cell, what it says: Dog and Cat

Example Cell, what it looks like:

Do

g

an

cat

What I'm aiming for:

Dog

and

Cat

Any help is much appreciated and thank you in advance.

 

[DarkJester89]

='User"&Char(10)&"Dashboard'!G2, so it's looking up a reference cell, not a direct hard-coded text in cell.

 

[Fluff]

You could change the formula to

=SUBSTITUTE('User Dashboard'!G2," ",CHAR(10))

 

[Dossfm0q]

Hi

Sub AutoFitWrapped_Formlua_Text()
Dim Rng As Range
   With Range("B2:CT2")
   .WrapText = True
        For Each Rng In .Cells
         With Rng
              If .HasFormula And Not .Formula Like "*SUBSTITUTE*" Then
              .Replace .Formula, "=SUBSTITUTE(" & Replace(.Formula, "=", "") & ","" "",CHAR(10))", xlPart, , , , False, False
              End If
          End With
         Next
         .EntireColumn.AutoFit
         .EntireRow.AutoFit
   End With
End Sub

 

[DarkJester89]

Thank you, now of the cells will go beyond 8 width, is it the CHAR (10) that's restricting it because some of the larger words that would go past time are being wrapped. Thank you in advance!

 

[DarkJester89]

 

[Fluff]

Have you changed the formula, or are you using the code supplied by Dossfm0q in post#13?

 

[Dossfm0q]

Check now please

Before:

WRAP (version 1).xlsb
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE
2	3M	CSOSS	PUBLICATIONS/INSTRUCTIONS	SUPPLY	DRY AIR	LIQUID COOLING	POWER DISTRIBUTION	TEST EQUIPMENT	CS READINESS ASSESSME	ELECTRONIC ATTACKIELE CTRONIC	FUNOAMEMTALS	MISSILES	COLLIMATION	COMBAT SYSTEMS ALIGNMENT	GYRO/MOTORS	SAFETY	SYNCHROS/SERVO	CHARACTERISTICS	DISPLAY SYSTEMS	INPUT/OUTPUT	NUMBERING SYSTEM	AC/DC THEORY	CORRECTIVE MAINTENANCE	FIBER OPTIC	FUNOAMEMTALS	POWER SUPPLIES	CHARACTERISTICS	CIRCUITS	MICROWAVE COMPONENTS	TRANSMTTTER/RECEIVER
Sheet6

After:

WRAP (version 1).xlsb
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE
2	3M	CSOSS	PUBLICATIONS/INSTRUCTIONS	SUPPLY	DRY AIR	LIQUID COOLING	POWER DISTRIBUTION	TEST EQUIPMENT	CS READINESS ASSESSME	ELECTRONIC ATTACKIELE CTRONIC	FUNOAMEMTALS	MISSILES	COLLIMATION	COMBAT SYSTEMS ALIGNMENT	GYRO/MOTORS	SAFETY	SYNCHROS/SERVO	CHARACTERISTICS	DISPLAY SYSTEMS	INPUT/OUTPUT	NUMBERING SYSTEM	AC/DC THEORY	CORRECTIVE MAINTENANCE	FIBER OPTIC	FUNOAMEMTALS	POWER SUPPLIES	CHARACTERISTICS	CIRCUITS	MICROWAVE COMPONENTS	TRANSMTTTER/RECEIVER
Sheet6

Sub AutoFitWrapped_Formlua_Text()
Application.ScreenUpdating = False
Dim Rng As Range
   With Range("B2:CT2")
  
        For Each Rng In .Cells
         With Rng
         .WrapText = False
              If .HasFormula And Not .Formula Like "*SUBSTITUTE*" Then
              .Replace .Formula, "=SUBSTITUTE(" & Replace(.Formula, "=", "") & ","" "",CHAR(10))", xlPart, , , , False, False
              End If
              .EntireColumn.AutoFit
              .WrapText = True
              .EntireColumn.AutoFit
              .HorizontalAlignment = xlCenter
              .VerticalAlignment = xlCenter

          End With
         Next
        
         .EntireRow.AutoFit
   End With
   Application.ScreenUpdating = True

End Sub

 

[Dossfm0q]

Also you have more option to Wrap after slash "/"

WRAP (version 1).xlsb
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE
2	3M	CSOSS	PUBLICATIONS/ INSTRUCTIONS	SUPPLY	DRY AIR	LIQUID COOLING	POWER DISTRIBUTION	TEST EQUIPMENT	CS READINESS ASSESSME	ELECTRONIC ATTACKIELE CTRONIC	FUNOAMEMTALS	MISSILES	COLLIMATION	COMBAT SYSTEMS ALIGNMENT	GYRO/ MOTORS	SAFETY	SYNCHROS/ SERVO	CHARACTERISTICS	DISPLAY SYSTEMS	INPUT/ OUTPUT	NUMBERING SYSTEM	AC/ DC THEORY	CORRECTIVE MAINTENANCE	FIBER OPTIC	FUNOAMEMTALS	POWER SUPPLIES	CHARACTERISTICS	CIRCUITS	MICROWAVE COMPONENTS	TRANSMTTTER/ RECEIVER
Sheet6

' Wrap after slah "/"'
Sub AutoFitWrapped_Formlua_Text()
Application.ScreenUpdating = False
Dim Rng As Range
   With Range("B2:CT2")
  
        For Each Rng In .Cells
         With Rng
         .WrapText = False
              If .HasFormula And Not .Formula Like "*SUBSTITUTE*" Then
             ' .Replace .Formula, "=SUBSTITUTE(" & Replace(.Formula, "=", "") & ","" "",CHAR(10))", xlPart, , , , False, False
              .Replace .Formula, "=SUBSTITUTE(SUBSTITUTE(" & Replace(.Formula, "=", "") & ","" "",CHAR(10)),""/"",""/""&CHAR(10))", xlPart, , , , False, False
              End If
              .EntireColumn.AutoFit
              .WrapText = True
              .EntireColumn.AutoFit
              .HorizontalAlignment = xlCenter
              .VerticalAlignment = xlCenter

          End With
         Next
        
         .EntireRow.AutoFit
   End With
   Application.ScreenUpdating = True

End Sub

 

[DarkJester89]

Thank you, confirmed works. beautiful code. Thanks for sharing

 

[Dossfm0q]

You are welcome, very very thanks for feedback