Hi All,

I have a problem where I want to run a macro on all rows selected by the
user. The problem lies in, that the macro when ran can create x amount
of new rows below the current one, based on a number entered by the user.
So what I want to do, is after compleating one row, deselect the row,
and the (x) number of new rows created by processing the current row.

Here is my code:

Sub IndividualProducts()

Dim Answer As VbMsgBoxResult ' Answer to our question
Answer = MsgBox("This function assumes that the colour codes are
places in column A. If this is not the case the function will fail, and
there will be no undo function." & vbCrLf & " Do you wish to proceed?", _
vbQuestion + vbYesNo, "Confirm") ' Ask the question and get
the results
If Answer = vbNo Then
Exit Sub ' If user clicks no then exit sub
End If
Dim Product As Integer
Dim Description As Integer

Product = InputBox("Please enter the column which contains the
Product ID, i.e 1", "User input")
Description = InputBox("Please Enter the column which contains the
description field of the item", "User Input")


Dim myCell As Range ' Declaire are range
Dim myCell2 As Range ' Declaire are range
Dim myR As Range ' Declaire are range
Dim myCodes As Variant ' Colour codes
Dim myFullCodes As Variant ' Full Colour Names
Dim i As Integer ' Itterator

Set myR = Selection.Cells(1).EntireRow ' Get the selected row
Set myCell = myR.Cells(1, 1) ' Get the cell containign
colour codes
myCodes = Split(myCell.Value, ",") ' Split the cell, via
the delimiter
Set myCell2 = myR.Cells(1, 2)
myFullCodes = Split(myCell2.Value, ",")

If LBound(myCodes) < UBound(myCodes) Then
myR.Copy ' Copy the range
myR.Resize(UBound(myCodes) -
LBound(myCodes)).Offset(1).Insert ' Resize it
'myR.Resize(UBound(myCodes) -
LBound(myCodes)).Offset(UBound(myCodes)).Insert
For i = LBound(myCodes) To UBound(myCodes) ' Loop
through the colour code list
myCell(i + 1, Product).Value = myCell(i + 1,
Product).Value & "/" & myCodes(i) ' Create individual product codes
myCell2(i + 1, 4).Value = myCell2(i + 1, 4).Value &
" " & myFullCodes(i)
Next i
End If
End Sub

If anyone could help I would be forever in your debt.

Kind regards

I haven't tested this code. but the solution is to get a count of the number
of times you need to go through the outer loop before adding any rows. then
keep a 2nd counter to indicate which row you are processing.

Sub xyz()

MyRows = Selection.Rows.Count
StartRow = Selection.Row
EndRow = StartRow + RowCount - 1

CurrentRow = Start_Row
For RowCount = 0 To (MyRows + 1)
Set myR = Cells(CurrentRow, "A").EntireRow ' Get the selected
row
' Get the cell containign colour codes
Set myCell = myR.Cells(1, 1)
' Split the cell, via the delimiter
myCodes = Split(myCell.Value, ",")
Set myCell2 = myR.Cells(1, 2)
myFullCodes = Split(myCell2.Value, ",")

If StarrtRow < EndRow Then
myR.Copy ' Copy the range
myR.Resize(UBound(myCodes) - _
LBound(myCodes)).Offset(1).Insert ' Resize it

For i = LBound(myCodes) To UBound(myCodes)
' Create individual product codes
myCell(i + 1, Product).Value = _
myCell(i + 1, Product).Value & "/" & myCodes(i)
myCell2(i + 1, 4).Value = myCell2(i + 1, 4).Value & _
" " & myFullCodes(i)
Next i
End If
Next RowCount
End Sub


"Materialised" wrote:

Hi All,

I have a problem where I want to run a macro on all rows selected by the
user. The problem lies in, that the macro when ran can create x amount
of new rows below the current one, based on a number entered by the user.
So what I want to do, is after compleating one row, deselect the row,
and the (x) number of new rows created by processing the current row.

Here is my code:

Sub IndividualProducts()

Dim Answer As VbMsgBoxResult ' Answer to our question
Answer = MsgBox("This function assumes that the colour codes are
places in column A. If this is not the case the function will fail, and
there will be no undo function." & vbCrLf & " Do you wish to proceed?", _
vbQuestion + vbYesNo, "Confirm") ' Ask the question and get
the results
If Answer = vbNo Then
Exit Sub ' If user clicks no then exit sub
End If
Dim Product As Integer
Dim Description As Integer

Product = InputBox("Please enter the column which contains the
Product ID, i.e 1", "User input")
Description = InputBox("Please Enter the column which contains the
description field of the item", "User Input")


Dim myCell As Range ' Declaire are range
Dim myCell2 As Range ' Declaire are range
Dim myR As Range ' Declaire are range
Dim myCodes As Variant ' Colour codes
Dim myFullCodes As Variant ' Full Colour Names
Dim i As Integer ' Itterator

Set myR = Selection.Cells(1).EntireRow ' Get the selected row
Set myCell = myR.Cells(1, 1) ' Get the cell containign
colour codes
myCodes = Split(myCell.Value, ",") ' Split the cell, via
the delimiter
Set myCell2 = myR.Cells(1, 2)
myFullCodes = Split(myCell2.Value, ",")

If LBound(myCodes) < UBound(myCodes) Then
myR.Copy ' Copy the range
myR.Resize(UBound(myCodes) -
LBound(myCodes)).Offset(1).Insert ' Resize it
'myR.Resize(UBound(myCodes) -
LBound(myCodes)).Offset(UBound(myCodes)).Insert
For i = LBound(myCodes) To UBound(myCodes) ' Loop
through the colour code list
myCell(i + 1, Product).Value = myCell(i + 1,
Product).Value & "/" & myCodes(i) ' Create individual product codes
myCell2(i + 1, 4).Value = myCell2(i + 1, 4).Value &
" " & myFullCodes(i)
Next i
End If
End Sub

If anyone could help I would be forever in your debt.

Kind regards