I need VB code to duplicate rows of data

mamyers64

New member
Joined
Apr 17, 2014
Messages
6
Reaction score
0
Points
0
I need to copy and duplicate rows of from one sheet to another. The number of duplicate rows will depend on a value in one of the columns.

Very simply example:

Sheet1
ProdCode No_of_Cases
123456-1 5
456789-0 3

Becomes in Sheet2

ProdCode Case_No
123456-1 1
123456-1 2
123456-1 3
123456-1 4
123456-1 5
456789-0 1
456789-0 2
456789-0 3
 

Attachments

  • Dup Sample.JPG
    Dup Sample.JPG
    39.6 KB · Views: 11
Code:
Public Sub Duplicate()
Dim lastrow As Long
Dim numrows As Long
Dim i As Long
    
    Application.ScreenUpdating = True


    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1").Resize(lastrow, 2).Copy Worksheets("Sheet2").Range("A1")
    End With
    
    With Worksheets("Sheet2")
    
        For i = lastrow To 2 Step -1
        
            If .Cells(i, 2).Value > 1 Then
            
                numrows = .Cells(i, "B").Value
                .Rows(i + 1).Resize(numrows - 1).Insert
                .Cells(i + 1, "A").Value = .Cells(i, "A").Value
                .Cells(i, "B").Value = 1
                .Cells(i + 1, "B").Value = 2
                .Cells(i, "A").Resize(, 2).AutoFill .Cells(i, "A").Resize(numrows, 2)
            End If
        Next i
        
        .Range("B1").Value = "Case_No"
    End With
    
    Application.ScreenUpdating = False
End Sub
 
Spoke too soon.

Sorry Bob, I spoke too soon.
The solution incorrectly resulted in changing the ProdCode values (performed a series fill-down effect).
Example:
123456-1
123456-2
123456-3
123456-4
123456-5
123456-6
123456-7
123456-8
123456-9
The requirement was to make them exact duplicates.
Another problem has to do with my inexperience with VB and my overly simplified example I provided. This make it really hard for me to convert the code to fit my actual data (attached this time). I actually need to duplicate 11 columns of data in a few different formats:
Julian_Date (general)
Date (date)
Vendor_Code (general)
Name (general)
PO_No (general)
Prod_Code (general)
Description1 (general)
Description2 (general)
DeliveryQuantity_Stk (number)
DeliveryQuantity_Alt (number)
StockLocation (general)
Lables (number) – This column becomes Label_Number and is supposed to be a sequential value of the count. All other columns are supposed to be exact duplicates of the source data.

Sorry about the confusion.
 

Attachments

  • Receiving Labels 2.0.xlsm
    50.3 KB · Views: 12
Code:
Public Sub Duplicate()Dim lastrow As Long
Dim numrows As Long
Dim i As Long
    
    Application.ScreenUpdating = True


    Worksheets("Cases Rows").UsedRange.ClearContents


    With Worksheets("Open_POs")
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1").Resize(lastrow, 12).Copy Worksheets("Cases Rows").Range("A1")
    End With
    
    With Worksheets("Cases Rows")
    
        For i = lastrow To 2 Step -1
        
            If .Cells(i, "L").Value > 1 Then
            
                numrows = .Cells(i, "L").Value
                .Rows(i + 1).Resize(numrows - 1).Insert
                .Rows(i).Copy .Cells(i + 1, "A").Resize(numrows - 1)
                .Cells(i, "L").Value = 1
                .Cells(i + 1, "L").Value = 2
                .Cells(i, "L").Resize(2).AutoFill .Cells(i, "L").Resize(numrows)
            End If
        Next i
        
        .Range("B1").Value = "Case_No"
    End With
    
    Application.ScreenUpdating = False
End Sub
 
Code:
Public Sub Duplicate()Dim lastrow As Long
Dim numrows As Long
Dim i As Long
    
    Application.ScreenUpdating = True


    Worksheets("Cases Rows").UsedRange.ClearContents


    With Worksheets("Open_POs")
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1").Resize(lastrow, 12).Copy Worksheets("Cases Rows").Range("A1")
    End With
    
    With Worksheets("Cases Rows")
    
        For i = lastrow To 2 Step -1
        
            If .Cells(i, "L").Value > 1 Then
            
                numrows = .Cells(i, "L").Value
                .Rows(i + 1).Resize(numrows - 1).Insert
                .Rows(i).Copy .Cells(i + 1, "A").Resize(numrows - 1)
                .Cells(i, "L").Value = 1
                .Cells(i + 1, "L").Value = 2
                .Cells(i, "L").Resize(2).AutoFill .Cells(i, "L").Resize(numrows)
            End If
        Next i
        
        .Range("B1").Value = "Case_No"
    End With
    
    Application.ScreenUpdating = False
End Sub

aaah, now it works perfectly for sure and I don't even need to make alterations to fix my need. You're a true guru Bob!:nod:
 
Back
Top