Hello,

I have a spreadsheet that has 2 columns. In Column A each row
has a single value. However, in Column B some cells have multiple
values as shown below. Is there a way to create some code to look at
each Cell in Column B and if it has multiple values, take each single
value and insert it into a separate cell below its original cell?

Example. CELL B20 has all the below text in it.

AXSMWVAL AXSQWQTS AXSDW056 AXSDWBD1 AXSDW072 AXSDW074 AXSDWCON
AXSDWEFT AXSDWEXT

CELL B21 = AXSDDIDS

I would like to know if there is a way to look at each value and
insert it into a separate Cell below B20 without over writing what was
in B21. So it would look like this:

B20 = AXSMWVAL
B21 = AXSQWQTS
B22 = AXSDW056
B23 = AXSDWBD1
B24 = AXSDW072
B25 = AXSDWCON
B26 = AXSDWEFT
B27 = AXSDWEXT
B28 = AXSDDIDS (This was what was originally in cell B21).

Any help would be greatly appreciated.

'=======Assumes same length of each block in string
option explicit
Sub BreakEmUpSAS()
Dim c As Range
Dim i As Long
For Each c In Range("b19:b20")
For i = 1 To Len(c) - 1 Step 9
Cells(Rows.Count, "c").End(xlUp)(2) = Mid(c, i, 9)
Next i
Next c
Columns("c").AutoFit
End Sub
'=========
On Feb 1, 7:49*am, DIDS wrote:
Hello,

* * *I have a spreadsheet that has 2 columns. *In Column A each row
has a single value. *However, in Column *B some cells have multiple
values as shown below. *Is there a way to create some code to look at
each Cell in Column B and if it has multiple values, take each single
value and insert it into a separate cell below its original cell?

Example. *CELL B20 has all the below text in it.

AXSMWVAL AXSQWQTS AXSDW056 AXSDWBD1 AXSDW072 AXSDW074 AXSDWCON
AXSDWEFT *AXSDWEXT

* * * * CELL B21 = AXSDDIDS

I would like to know if there is a way to look at each value and
insert it into a separate Cell below B20 without over writing what was
in B21. *So it would look like this:

B20 * * = * * * AXSMWVAL
B21 * * = * * * AXSQWQTS
B22 * * = * * * AXSDW056
B23 * * = * * * AXSDWBD1
B24 * * = * * * AXSDW072
B25 * * = * * * AXSDWCON
B26 * * = * * * AXSDWEFT
B27 * * = * * * AXSDWEXT
B28 * * = * * * AXSDDIDS * (This was what was originally in cell B21).

Any help would be greatly appreciated.

Hi Don,

Thank you for your reply. I have been working on this and
cobbing together code I found on some sites and it does what I want
except for one issue. If a Cell in Column B is blank. It is copying
the cell above it into the cell that should be blank. So what I want
to do is if the cell in Column B is blanck leave it blank. Any ideas
on how to accomplish this? Any help would be appreciated.


This is what I have before running my code:

CELL B92 = AXIQWQTS
CELL B93 = Blank Cell
CELL B94 = AXIDDIDS


This is what I have after running my code:

CELL B92 = AXIQWQTS
CELL B93 = AXIQWQTS
CELL B94 = AXIDDIDS


Here is my code:

Dim LR As Long, i As Long, LC As Integer
Dim X As Variant
Dim r As Range, iCol As Integer
On Error Resume Next
Set r = Application.InputBox("Click in the column to split by",
Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
Application.ScreenUpdating = False
LC = Cells(1, Columns.Count).End(xlToLeft).Column
LR = Cells(Rows.Count, iCol).End(xlUp).Row
Columns(iCol).Insert
For i = LR To 1 Step -1
With Cells(i, iCol + 1)
If InStr(.Value, " ") = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, " ")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value =
Application.Transpose(X)
End If
End With
Next i
Columns(iCol + 1).Delete
LR = Cells(Rows.Count, iCol).End(xlUp).Row
With Range(Cells(1, 1), Cells(LR, LC))
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
With Columns("B")
.Replace What:="EOJ", Replacement:="#N/A", _
LookAt:=xlWhole, MatchCase:=False
.SpecialCells(xlConstants, xlErrors).EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub

On Feb 1, 10:22*am, DIDS wrote:
Hi Don,

* * * Thank you for your reply. *I have been working on this and
cobbing together code I found on some sites and it does what I want
except for one issue. *If a Cell in Column B is blank. *It is copying
the cell above it into the cell that should be blank. *So what I want
to do is if the cell in Column B is blanck leave it blank. *Any ideas
on how to accomplish this? *Any help would be appreciated.

This is what I have before running my code:

CELL B92 = AXIQWQTS
CELL B93 = Blank Cell
CELL B94 = AXIDDIDS

This is what I have after running my code:

CELL B92 = AXIQWQTS
CELL B93 = AXIQWQTS
CELL B94 = AXIDDIDS

Here is my code:

Dim LR As Long, i As Long, LC As Integer
Dim X As Variant
Dim r As Range, iCol As Integer
On Error Resume Next
Set r = Application.InputBox("Click in the column to split by",
Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
Application.ScreenUpdating = False
LC = Cells(1, Columns.Count).End(xlToLeft).Column
LR = Cells(Rows.Count, iCol).End(xlUp).Row
Columns(iCol).Insert
For i = LR To 1 Step -1
* * With Cells(i, iCol + 1)
* * * * If InStr(.Value, " ") = 0 Then
* * * * * * .Offset(, -1).Value = .Value
* * * * Else
* * * * * * X = Split(.Value, " ")
* * * * * * .Offset(1).Resize(UBound(X)).EntireRow.Insert
* * * * * * .Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value =
Application.Transpose(X)
* * * * End If
* * End With
Next i
Columns(iCol + 1).Delete
LR = Cells(Rows.Count, iCol).End(xlUp).Row
With Range(Cells(1, 1), Cells(LR, LC))
* * On Error Resume Next
* * .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
* * On Error GoTo 0
* * .Value = .Value
End With
* * * * With Columns("B")
* * * * * * .Replace What:="EOJ", Replacement:="#N/A", _
* * * * * * * * LookAt:=xlWhole, MatchCase:=False
* * * * * * .SpecialCells(xlConstants, xlErrors).EntireRow.Delete
* * * * End With
Application.ScreenUpdating = True
End Sub

What's wrong with what I gave you with ONE line added

Sub BreakEmUpSAS()
Dim c As Range
Dim i As Long
For Each c In Range("b19:b21")
'==added
If c = "" Then Cells(Rows.Count, "c").End(xlUp)(2) = "'"
'==
For i = 1 To Len(c) - 1 Step 9
Cells(Rows.Count, "c").End(xlUp)(2) = Mid(c, i, 9)
Next i
Next c
Columns("c").AutoFit
End Sub