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

  • Thread starter Thread starter DIDS
  • Start date Start date
D

DIDS

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
'=========
 
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
 
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
Click to expand...

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
 
Back
Top