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 <did...@gmail.com> 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 incell 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 <did...@gmail.com> 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