CODEWITHSUNDEEP
vbaexcel
Hunga
Hunga

Reputation: 51

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)

enter image description here

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.

enter image description here

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

Upvotes: 2

Views: 1492

Answers (2)

user4039065
user4039065

Reputation:

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

Upvotes: 0

urdearboy
urdearboy

Reputation: 14580

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).

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) 

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

Edit:

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")

Upvotes: 2

Related Questions