Results 1 to 6 of 6

Thread: I need VB code to duplicate rows of data

  1. #1

    I need VB code to duplicate rows of data



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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
    Attached Thumbnails Attached Thumbnails Click image for larger version. 

Name:	Dup Sample.JPG 
Views:	8 
Size:	39.6 KB 
ID:	2246  

  2. #2
    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

  3. #3
    This works perfectly. Thank you Bob!

  4. #4

    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.
    Attached Files Attached Files

  5. #5
    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

  6. #6
    Quote Originally Posted by Bob Phillips View Post
    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!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •