Making 1 row in Excel duplicate based on a cell value

I'm trying to make a row in a worksheet in excel duplicate into several rows in another worksheet in the same workbook based on a cell value.

I want to enter the number of aliquots derived from a sample and carry all the information over to another worksheet but duplicate the row's information based on the value I put in the 'aliquots' column.

See pic - So for line 2 I would like for this in the 2nd worksheet to turn into 4 rows (based on the value in column R) instead of just one. And for line 3 I would like for this to become 2 rows instead of just one. And for line 4 I would like this to stay as only 1 row.

Is this possible?

I am assuming that you want to copy all over in one operation and not row by row as data is entered in the source data sheet.

It is always good policy to back up your workbook first in case the code does not perform as you expect.

Following guidelines to install the VBA code in case you require them:

  1. Alt and F11 to open the VBA editor window
  2. In the VBA editor select menu item Insert -> Module
  3. Copy the VBA code below and paste into the VBA editor.
  4. Edit the code where indicated with the comments in the code (Comments will be green when pasted into the VBA editor. Only 2 lines with comments require editing by you.)
  5. Close the VBA editor (Cross very top right of VBA editor window)
  6. Save the workbook as Macro enabled.
  7. Ensure macros are enabled. See help for how to do this. (Option to "Disable all macros with notification" should be OK.)
  8. If Developer ribbon not displaying then right click anywhere in one of the ribbons and select "Customize the ribbon". On the right side of the dialog check the box against "Developer" and click OK.
  9. To run the macro, on the Developer ribbon select Macro icon (towards left in Code block) and then select the macro name (CopyData) and click Run.
  10. You can also insert a button on the worksheet to run the code and if you require guidelines to do so then please get back to me.

Copy all of the following code into the VBA editor.


Sub CopyData()
    Dim wsSource As Worksheet       'Source data worksheet
    Dim wsDestin As Worksheet       'Destination worksheet
    Dim rngSource As Range          'First column of source data
    Dim rngDestin As Range          'Destination range (Includes multiple rows)
    Dim lngLastRow As Long          'Last row of data on worksheet (Source and Destination)
    Dim lngLastCol As Long          'Last column of data on worksheet (Source and Destination)
    Dim rCel As Range               'Each cell of the first column ong Source data
    Dim lngMulti As Long            'Number of rows in destination (from column "R")

   

    Set wsSource = Worksheets("Sheet1")     'Edit "Sheet1" to your Source data worksheet
    Set wsDestin = Worksheets("Sheet2")     'Edit "Sheet2" to your Destination data worksheet
   
    With wsSource
        lngLastRow = LastRowOrCol(True, .Cells)     'Last row with data on Source worksheet
        lngLastCol = LastRowOrCol(False, .Cells)    'Last Column with data on Source worksheet
        Set rngSource = .Range(.Cells(2, "A"), .Cells(lngLastRow, "A")) 'First column of data on Source Worksheet
    End With
   
    For Each rCel In rngSource
        lngMulti = rCel.Offset(0, 17).Value     'Number of copies. (Offset 17 from column "A" is column "R")
        With wsDestin
            lngLastRow = LastRowOrCol(True, .Cells)    'Last used row with data on Destination worksheet
            'Next code line sets the entire destination range with mutiple lines as per column "R"
            Set rngDestin = .Range(.Cells(lngLastRow + 1, "A"), .Cells(lngLastRow + lngMulti, lngLastCol))
        End With
           
        'Copy the source data to the Destination
        Range(rCel, rCel.Offset(0, lngLastCol - 1)).Copy Destination:=rngDestin
    Next rCel
   
End Sub

Function LastRowOrCol(bolRowOrCol As Boolean, Optional rng As Range) As Long
    'Finds the last used row or column in a worksheet
    'First parameter is True for Last Row or False for last Column
    'Third parameter is optional
        'Must be specified if not ActiveSheet
   
    Dim lngRowCol As Long
    Dim rngToFind As Range
   
    If rng Is Nothing Then
        Set rng = ActiveSheet.Cells
    End If
   
    If bolRowOrCol Then
        lngRowCol = xlByRows
    Else
        lngRowCol = xlByColumns
    End If
   
    With rng
        Set rngToFind = rng.Find(What:="*", _
                LookIn:=xlFormulas, _
                LookAt:=xlPart, _
                SearchOrder:=lngRowCol, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False)
    End With
   
    If Not rngToFind Is Nothing Then
        If bolRowOrCol Then
            LastRowOrCol = rngToFind.Row
        Else
            LastRowOrCol = rngToFind.Column
        End If
    End If
   
End Function

Regards,

OssieMac

Was this reply helpful?

Sorry this didn't help.

Great! Thanks for your feedback.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this reply?

Thanks for your feedback.

Excel 2016 with Power Query (aka Get & Transform)

No formulas, no VBA macro.

Table, not cell based, references.

http://www.mediafire.com/file/6dobxbb3vp1m2cg/12_04_17.xlsx

http://www.mediafire.com/file/qy7amazuiq8w784/12_04_17.pdf

Was this reply helpful?

Sorry this didn't help.

Great! Thanks for your feedback.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this reply?

Thanks for your feedback.

 
 

Question Info


Last updated July 13, 2021 Views 717 Applies to: