Break Apart a Cell, please help a newby

[Guest]

I was hoping someone had some code already developed for this application,
any help you could provide would be appreciated.

In Cell A1 I have the following
RE32121 RE65456 RE789456

I need a macro that will find the first space and move the remaining data
into the cell below it, ie
RE32121
RE65456 RE789456

Then it needs to continue this process for something like 10000 rows, the
next space would finish this cell as their would be no more spaces to break
apart.
RE32121
RE65456
RE789456

 

[Ed Ferrero]

Hi,

Have a look at Data -> Text to Columns - use delimited data with space as a
delimiter.

Ed Ferrero
www.edferrero.com

 

[Gord Dibben]

Newby

I would use Text to Columns to break the data into 3 columns then combine the 3
into 1.

This macro does the Text to Columns then re-combines into one column on a new
worksheet.

Note: takes about 50 seconds to run through the 10000 original cells. If I
didn't have so many "selects" it would run faster.

Sub rowstocol()
Dim wks As Worksheet
Dim colnos As String 'Long
Dim CopytoSheet As Worksheet

If ActiveSheet.Name = "Copyto" Then
MsgBox "Active Sheet Not Valid" & Chr(13) _
& "Try Another Worksheet."
Exit Sub

Else
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
TrailingMinusNumbers:=True

Set wks = ActiveSheet
Application.ScreenUpdating = False
For Each Wksht In Worksheets
With Wksht
If .Name = "Copyto" Then
Application.DisplayAlerts = False
Sheets("Copyto").Delete
End If
End With
Next
Application.DisplayAlerts = True
Set CopytoSheet = Worksheets.Add
CopytoSheet.Name = "Copyto"
wks.Activate
Range("A1").Select

On Error Resume Next
colnos = InputBox("Enter Number of Columns to Combine")
If colnos = "" Or colnos < 2 Then Exit Sub
StartTime = Timer
Do Until ActiveCell.Value = ""
ActiveCell.Offset(1, 0).Select
With ActiveCell
.Resize(1, colnos).Copy
End With
Sheets("Copyto").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _
SkipBlanks:=False _
, Transpose:=True
Application.CutCopyMode = False
ActiveSheet.Cells(Rows.Count,ActiveCell.Column).End(xlUp).Select
ActiveCell.Offset(1, 0).Select

wks.Activate
ActiveCell.Select
Loop
Sheets("Copyto").Activate
End If

MsgBox Timer - StartTime
End Sub


Gord Dibben MS Excel MVP