copy rows multiple times (given in a cell) and add unique id number based on cells

I have a big table containing data like this one (ProductName, ProductId, RepeatNumber)

I would like to create a new dataset on a new Sheet (Sheet2). The macro would copy data from Sheet1 and it would Insert rows as many times as it can be seen in the column C (the enclosed macro can already do that) but i would like to place these data on a new Sheet (Sheet2) and to give an ItemId in the Column B on the new sheet (on Sheet2) which is created by ProductID.
The first 5 character of the ItemId is the same as the ProductId and the last two one is 01, 02, 03 and so on until the repeatnumber.

Since these original data on Sheet1 are changing continously, that is new rows are added on Sheet1, i would like an input box for giving the rownumber from where the macro needs to run.
The first data (created by the macro) would be placed in the last nonempty rows of the column A of Sheet2.
First time the input value would be 2 (the macro needs to run from the second row).

How can i create that special ItemId on the new Sheet as many times as i need?

Thanks in advance.

I have macro like this:

Sub Multicopy()

Dim xRow As Long

Dim RepeatNum As Variant

xRow = 1

Application.ScreenUpdating = False

Do While (Cells(xRow, "A") <> "")

RepeatNum = Cells(xRow, "C")

If ((RepeatNum > 1) And IsNumeric(RepeatNum)) Then

Range(Cells(xRow, "A"), Cells(xRow, "C")).Copy

Range(Cells(xRow + 1, "A"), Cells(xRow + RepeatNum - 1, "C")).Select

Selection.Insert Shift:=xlDown

xRow = xRow + RepeatNum - 1

End If

xRow = xRow + 1

Loop

Application.ScreenUpdating = False

End Sub


2 Answers
2

This seems a little more effective/straight forward then the approach you are taking.

The code will run from StartRow (as determined by user in InputBox) until LRow (determined form Sheet1 Col A).

StartRow

InputBox

LRow

Sheet1 Col A

The i loop will loop through the range specified above on Sheet1 Col A.
The j loop determines how many times to "paste" your values (specified from Sheet1 Col C)

i

Sheet1 Col A

j

Sheet1 Col C

Sub Test()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim StartRow As Long, LRow As Long, i As Long, j As Long

LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
StartRow = Application.InputBox("Enter Row Number to Start On", , , , , , , 1)

For i = StartRow To LRow
For j = 1 To ws.Range("A" & i).Offset(, 2).Value
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Offset(1).Row
ws2.Range("A" & LRow2).Value = ws.Range("A" & i).Value
ws2.Range("B" & LRow2).Value = ws.Range("B" & i).Value & j
Next j
Next i

End Sub


It will be worth while validating the InputBox entry (should be from first available row - last available row). You will also need state some actions for when the user hits the Cancel button on the InputBox

InputBox

Cancel

InputBox

You can format your serial number from 1 to 01 by changing ws.Range("B" & i).Value & j to ws.Range("B" & i).Value & WorksheetFunction.Text( j , "00")

ws.Range("B" & i).Value & j

ws.Range("B" & i).Value & WorksheetFunction.Text( j , "00")

You are fantastic. It works perfectly. Thank you so much.
– Hunga
2 days ago

You had stated that you wanted the expanded values on a 'new sheet' and I took that literally. This routine creates a new worksheet and names it Items. FillDown is used for static expansion while AutoFill with xlFillSeries is used for progressive expansion.

Option Explicit

Sub Multicopy()
Dim i As Long, arr As Variant

With Worksheets("sheet1")
arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "C").End(xlUp)).Value2
End With

With Worksheets.Add(after:=Worksheets("sheet1"))
.Name = "Items"
.Cells(1, "A").Resize(1, 2) = Array("ProductName", "ItemID")

For i = LBound(arr, 1) To UBound(arr, 1)
With .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
.Resize(1, 2) = Array(arr(i, 1), arr(i, 2) & "01")
.Resize(arr(i, 3), 1).FillDown
.Offset(0, 1).AutoFill Type:=xlFillSeries, _
Destination:=.Offset(0, 1).Resize(arr(i, 3), 1)
End With
Next i
End With

End Sub


By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.