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

DIDS
Guest
Posts: n/a

 1st Feb 2012
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.

Don Guillett
Guest
Posts: n/a

 1st Feb 2012
'=======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.

DIDS
Guest
Posts: n/a

 1st Feb 2012
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

Don Guillett
Guest
Posts: n/a

 2nd Feb 2012
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")
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

 Thread Tools Rate This Thread Rate This Thread: 5 : Excellent 4 : Good 3 : Average 2 : Bad 1 : Terrible

 Posting Rules You may not post new threads You may not post replies You may not post attachments You may not edit your posts BB code is On Smilies are On [IMG] code is On HTML code is OffTrackbacks are On Pingbacks are On Refbacks are Off Forum Rules

 Similar Threads Thread Thread Starter Forum Replies Last Post New Hope UMC Microsoft Excel Worksheet Functions 3 12th Jan 2011 06:16 PM New Hope UMC Microsoft Excel Discussion 0 6th Jan 2011 02:28 PM se7098 Microsoft Excel Worksheet Functions 11 18th Sep 2008 12:04 AM El Shish Microsoft Excel Misc 9 18th Aug 2006 04:30 PM =?Utf-8?B?Y2VjaQ==?= Microsoft Excel Worksheet Functions 3 18th Aug 2005 08:58 PM

Features