Make copies of a row based on a value and copy data based on a column

[Nirbhay Sharma]

Hi everyone

So I am having an excel file with some data in it. see sample file.

now i want to achieve the following:

- check for the number of products bought by a customer.
- after obtaining that, we have to create that many records for the customer.
- example: john has bought 5 suitcases and 2 wallets. then there will be two rows for john.
- also we will populate the "product qty" columns with the respective product values.
example: for john, there would be two rows. one row will have the values 5 in product qty and other will have 2.

i have so far tried to obtain the number of copies that are required by applying this formula in column J; =COUNTIF(F2:H2,">"&0)-1

also i have applied this formula to get which value has to be copied in the product qty column (if there are more than one copies req.)

is there any macro or any way someone can suggest to implement this logic?

thanks in advance

 

[Nebu]

Hi :
Try the below code.

Sub CopyRows()
Application.ScreenUpdating = False
Dim i, j, l, m As Long

i = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row

For j = i To 2 Step -1
l = Sheet1.Range("J" & j)

    Select Case l
        Case 1
            Rows(j).Offset(1, 0).Resize(1).Insert
            Rows(j).Copy
            Rows(j).Offset(1, 0).PasteSpecial xlValues
           
                If Cells(j, 7).Offset(1, 0) <> 0 Then
                    Cells(j, 6).Offset(1, 0).ClearContents
                    Cells(j, 8).Offset(1, 0).ClearContents
                ElseIf Cells(j, 8).Offset(1, 0) <> 0 Then
                    Cells(j, 6).Offset(1, 0).ClearContents
                    Cells(j, 7).Offset(1, 0).ClearContents
                End If
               
            Cells(j, 10).Offset(1, 0).ClearContents
            Cells(j, 7).ClearContents
            Cells(j, 8).ClearContents
        Case 2
            Rows(j).Offset(1, 0).Resize(2).Insert
            Rows(j).Copy
            Rows(j).Offset(1, 0).PasteSpecial xlValues
            Rows(j).Offset(2, 0).PasteSpecial xlValues
                       
                If Cells(j, 7).Offset(1, 0) <> 0 Then
                    Cells(j, 6).Offset(1, 0).ClearContents
                    Cells(j, 8).Offset(1, 0).ClearContents
                End If
                If Cells(j, 8).Offset(2, 0) <> 0 Then
                    Cells(j, 6).Offset(2, 0).ClearContents
                    Cells(j, 7).Offset(2, 0).ClearContents
                End If
           
            Cells(j, 10).Offset(1, 0).ClearContents
            Cells(j, 10).Offset(2, 0).ClearContents
            Cells(j, 7).ClearContents
            Cells(j, 8).ClearContents
    End Select
Next
Application.ScreenUpdating = True
End Sub

Thanks