Is there a way to place the cell contents separated by a comma byinserting a new line and then copyi

[anshu minocha]

Hiii,

I have a problem with the following code:

Suppose

Data:
colC Col D

Row 1 Phase SP#
Row 2 1-0210 60625IT1m,60625EO1m
Row 3 2-0210 60625IT2,60625RB2

Output obtained after running the code:

colC Col D

Row 1 Phase SP#
Row 2 1-0210 60625IT1m
Row 3 2-0210 60625EO1m
Row 4 60625IT2
Row 5 60625RB2


Output Desired:while separating the values for SP# and placing them on
new cells,
The code should be able to insert a new line and copy the cell
contents on it as shown below else it is not possible to distinguish
which SP# belong to which Phase.

colC Col D

Row 1 Phase SP#
Row 2 1-0210 60625IT1m
Row 3 60625EO1m
Row 4 2-0210 60625IT2
Row 5 60625RB2

Please help me find the flaw with the code below, Any help would be
appreciated.
Thankyou.

'Step 3:This Macro is to arrange SP# from one cell to different cells
in the column
Sub Arrange_SP()
Dim myArr As Variant
Dim CS As String 'Hold the string value of the current cell being
checked.
Dim CR As Long 'Current Row number to be checked for possible array.
Dim NR As Long 'Upper Bound element number of Array
'Lower Bound number in this instance will always be
'0'
Dim FR As Long 'First Row number of range to be checked.
Dim LR As Long 'Last Row number of range to be checked.
Dim I As Long


FR = 2
LR = 1194


For CR = FR To LR
CS = Range("D" & CR).Value 'D here indicates that our SP# column
is D in the SP Template
If InStr(1, CS, ",", 0) > 0 Then
myArr = Split(CS, ",")
NR = UBound(myArr)
Range("D" & CR).Offset(1, 0).Resize(NR, 11).Insert
(xlShiftDown)
For I = 0 To NR
Range("D" & CR + I).Value = myArr(I)
Next I
CR = CR + NR
LR = LR + NR
End If
Next CR
End Sub

Thanks

 

[Matthew Herbert]

Anshu,

I've included some illustrative code below. Take note that the Find method
uses only one argument (and you should look at Find in the VBE help and at
least note that the Find settings are retained for each use). Also, I'm
using Step-1 in the For Next loop rather than looping forward and having to
adjust the counter (not to mention shifting the cells down by a random 11
cells--unless those 11 cells serve a special purpose). Lastly, I'm using
code that will dynamically find the last row rather than hard coding a 1194
as "LR." Though ".EntireRow.Insert" takes time, it should be okay in this
situation. An alternative would be to create an array, run everything
internally within VBE, and then output the array to the worksheet.
Nonetheless, I think that the code below should at least give you some ideas.

Best,

Matthew Herbert

Sub ArrangeSP()
Dim varArr As Variant
Dim lngRowStart As Long
Dim lngRowEnd As Long
Dim rngFound As Range
Dim rngTemp As Range
Dim rngInsert As Range
Dim lngCntRow As Long
Dim lngCntArr As Long
Dim Wks As Worksheet

Application.ScreenUpdating = False

'create a worksheet object that references the "SP" data
Set Wks = Worksheets(1)

'find the "SP" column header within the first row of the
' "SP" worksheet
Set rngFound = Wks.Rows(1).Find("SP#")
If rngFound Is Nothing Then
MsgBox "Couldn't find 'SP#'"
Exit Sub
End If

'don't include the header row as part of the evaluation
lngRowStart = 2

'get the last row in the "SP" column
With Wks
lngRowEnd = .Cells(.Rows.Count, rngFound.Column).End(xlUp).Row
End With

With Wks
'loop through the rows
For lngCntRow = lngRowEnd To lngRowStart Step -1

'create a temporary range to reference as
' part of the evaluation process
Set rngTemp = .Cells(lngCntRow, rngFound.Column)

With rngTemp

'if a comma exists, continue on by splitting the data
' by the comma and then inserting the data in the
' appropriate "Phase" column
If InStr(1, .Value, ",", vbBinaryCompare) > 0 Then

'Split creates a zero-based array
varArr = Split(.Value, ",")

'insert the number of rows below the current cell
Set rngInsert = rngTemp.Resize(UBound(varArr)).Offset(1, 0)
rngInsert.EntireRow.Insert

'insert the varArr data in the newly inserted rows
For lngCntArr = LBound(varArr) To UBound(varArr)
.Offset(lngCntArr, 0).Value = varArr(lngCntArr)
Next lngCntArr
End If
End With
Next lngCntRow
End With

End Sub