Move multiple values in single Cell To Cells of there own?
 

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.

Move multiple values in single Cell To Cells of there own?
 

'=======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.

Move multiple values in single Cell To Cells of there own?
 

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

Move multiple values in single Cell To Cells of there own?
 

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