Develop excel macro to create duplicate rows of records based on criteria

Posted on 2007-08-06
Medium Priority
Last Modified: 2009-06-19
Max points for Macro to Copy Excel Rows

Help&need to accomplish the following: Copy rows from one excel spreadsheet to another with each row being copied multiple times based upon the value in a specific column within the row.


Within an active worksheet I have several records&looks something like this

        A                       B               C               D
1       # of Positions  Title           Salary  Location
2       3                       Prez            150K            NY
3       5                       Sales           25K             CA
4       2                       Ops             55K             FL

Need to take each row and copy it into a new spreadsheet (in the same workbook would be fine) so that there would multiple rows for each Title (Rows 2-4 in the above) based upon the # of positions indicated in Column A.  So the output in the new spreadsheet would look like this (Note the addition of column E which indicates a cumulate count for each title (e.g. Prez has 3 positions so the count runs 1-3 indicating each unique record):

        A                       B               C               D               E
1       # of Positions  Title           Salary  Location        Position ID
2       3                       Prez            150K            NY              1
3       3                       Prez            150K            NY              2              
4       3                       Prez            150K            NY              3
5       5                       Sales           25K             CA              1
6       5                       Sales           25K             CA              2
7       5                       Sales           25K             CA              3
8       5                       Sales           25K             CA              4
9       5                       Sales           25K             CA              5
10      2                       Ops             55K             FL              1
11      2                       Ops             55K             FL              2

There are approximately 150 sheets with similar information (standardized format...but there are rows above and below the content that may not be standardized, so will need to be able to specify that only the data in rows 10-30 (or some other range) should be copied into the new spreadsheet.

All sheets have unique names, so it may be best to create a macro that can be run by selecting a sheet and running the macro while a particular sheet is active...
Question by:utmba02
LVL 13

Expert Comment

ID: 19640091
'try this macro
Sub positionelements()

Dim currentvalue As Integer, srow As Integer, pos as Integer,sheetindex,col as Integer
srow = 2
sheetindex = ActiveWorkbook.Sheets.Count
col = ActiveSheet.UsedRange.Columns.Count
ActiveWorkbook.Sheets.Add after:=Worksheets(ActiveWorkbook.Sheets.Count)
For i = 1 To ActiveSheet.UsedRange.Rows.Count
      pos = 1
      currentvalue = Val(ActiveSheet.Cells(i, 1))
      For k=1 to currentvalue
          ActiveSheet.Rows(i).Copy  Destination:=ActiveWorkbook.Sheets(sheetindex).Rows(srow)
       ActiveWorkbook.Sheets(sheetindex).Cells(srow,col+1) = k
       srow = srow + 1

End Sub

Author Comment

ID: 19640293
Thanks, as a novice I have run the macro, but it only creates a new sheet.  How do I configure it to identify the specific rows and ranges that need to be duplicated and then have it copy to the new worksheet?

The third column will be the identifier where the record is greater than 1 for that row to duplicated the number of times it is identified as.
LVL 24

Accepted Solution

R_Rajesh earned 2000 total points
ID: 19640622
In your xl sheet hit alt+f11. This opens the vbe window. Select module from the insert menu and paste the following code. Close the vbe window. Back in xl hit alt+f8, select test and click on run.
Once the pompt comes up, use the mouse to select the entire range to be processed. In this example the column_identifier is set to 1. If the identifier is in some other column, set its value accordingly.

Sub test()
Dim myRange As Range
Dim tSht, nSht, i, j, column_identifier
column_identifier = 1
Set tSht = ActiveSheet: Set nSht = Sheets.Add: tSht.Activate
Set myRange = Application.InputBox(Prompt:="Use your mouse to select the range", Type:=8)
For Each c In myRange.Columns(column_identifier).Cells
For i = 1 To Val(c)
j = j + 1
Range(Cells(c.Row, myRange.Columns(1).Column), Cells(c.Row, myRange. _
Columns(1).Column + myRange.Columns.Count - 1)).Copy nSht.Cells(j, 1)
nSht.Cells(j, myRange.Columns.Count + 1) = i
Next i
Next c
End Sub

Expert Comment

ID: 23687446
I am very new to Macros & am trying to make this solution work in an Excel07 file for a project due today- Help!

Like the original post I want to have rows automatically multiplied & copied, based on any quantity over 0 in the Number column.  I want the exact same output as the original post requested.  My column identifier was changed to 13, as that is the column that contains the qty data.  When I tried to macro information in the above solution, it just results in a blank page when I test it within the worksheet.  Suggestions?  


Featured Post

Get your problem seen by more experts

Be seen. Boost your question’s priority for more expert views and faster solutions

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

615 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question