Excel VBA: routine for duplicating rows in a large range of data based on criteria

Hello,
I need help creating a routine that duplicates all rows of data that fit certain criteria. Let's say there is an existing tab with data in the workbook. The user would go into the Setup tab and specify that for the certain criteria in the existing data let's say year, and a group he wants to create duplicates of the existing sub-group. I am attaching a file with a small slice of data for ease of illustration:
sample-file.xlsx
Dmitriy KritskiyAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
In the real Setup tab will there be more than one year? Will there possibly be more subgroups than B and C?
Martin LissOlder than dirtCommented:
Or does the user enter the year and and all the 'Additional subgroup(s)' and 'Within Group' values?
Martin LissOlder than dirtCommented:
Is the Source Data tab sorted by Year/Group/Sub-group?
Introduction to R

R is considered the predominant language for data scientist and statisticians. Learn how to use R for your own data science projects.

Dmitriy KritskiyAuthor Commented:
there can be more than year, more than one group in the source tab. The tab is not necessarily sorted. Does it make a difference? I could potentially instruct the user to sort the tab before proceeding.

There can be other additional subgroups, so it could be: add subgroups B,C,D,E, to group 1, and also add subgroup B to group 2, so there is no limit per se.
Martin LissOlder than dirtCommented:
Where on the Setup tab will the other years be?
Dmitriy KritskiyAuthor Commented:
well the operation will be done only for one year in the source data, not for multiple years. So if there are other years there they will not be copied over to the Output tab.
Martin LissOlder than dirtCommented:
So just to see if In understand - at any given time there will only be one year on the Setup tab. Correct?
Dmitriy KritskiyAuthor Commented:
yes sir
Martin LissOlder than dirtCommented:
Try this macro.

Sub ProduceOutput()
Dim lngLastRowSU As Long
Dim lngLastRowSD As Long
Dim lngRowSU As Long
Dim lngRowSD As Long
Dim lngLastColumn As Long
Dim lngNewRow As Long
Dim wsOD As Worksheet
Dim wsSD As Worksheet
Dim wsSU As Worksheet

Set wsOD = Sheets("Output Data")
Set wsSD = Sheets("Source Data")
Set wsSU = Sheets("Setup")

lngLastRowSD = wsSD.Range("A1048576").End(xlUp).Row
lngLastRowSU = wsSU.Range("A1048576").End(xlUp).Row
lngLastColumn = wsSD.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
lngNewRow = 2

wsOD.Rows(1).EntireRow.Value = wsSD.Rows(1).EntireRow.Value

For lngRowSU = 7 To lngLastRowSU
    For lngRowSD = 2 To lngLastRowSD
        If wsSD.Cells(lngRowSD, 1) = wsSU.Range("B4") Then
            If wsSD.Cells(lngRowSD, 3) = wsSU.Cells(lngRowSU, 1) And _
               wsSD.Cells(lngRowSD, 2) = wsSU.Cells(lngRowSU, 2) Then
                wsOD.Rows(lngNewRow).EntireRow.Value = wsSD.Rows(lngRowSD).EntireRow.Value
                lngNewRow = lngNewRow + 1
            End If
        End If
    Next
Next

End Sub

Open in new window


My apologies if you already know how to add a macro but just in case...
In Excel, Press Alt+F11 to open Visual Basic Editor (VBE)

Right-click on your workbook name in the "Project-VBAProject" pane (at the top left corner of the editor window) and select Insert -> Module from the context menu

Copy the macro (you can use the ‘Select All’ button if you like) and paste it into the right-hand pane of the VBA editor ("Module1" window)

Press Alt+F11 again to go back to Excel

Optionally, press Alt+F8 to open the "Macro" dialog window. Select the macro, click ‘Options…’,  hold down the Shift key and type the letter A (or any other letter) and click ‘OK’.  Then anytime you want to run the macro press Ctrl+Shift+A
Dmitriy KritskiyAuthor Commented:
Hi Martin,
nothing happens beyond copying of the header row so far...
sample-file.xlsm
Martin LissOlder than dirtCommented:
Maybe I've misunderstood the requirements. Currently I'm creating the output data form the source data if the year matches and 'Within Group' matches 'Group' and 'Additional subgroup(s)' matches 'Sub-group', and so there's no output because there's no matching Sub-Group. Please tell me what I should do instead.
Dmitriy KritskiyAuthor Commented:
Martin, I think my initial explanation might have been confusing. Let me try again - the main idea here is to give the user functionality to add subgroups (from one to many, and in our specific example just two: B, C) with in specified year and group by just copying all of the subgroup A data. (subgroup A is a default subgroup that's always present in the data set). For other groups within this year they should just be copied over since no additions are specified. I expanded the example file, and specifically sample output so that it's a bit more clear. Let me know if you have any questions.
sample-file.xlsm
Martin LissOlder than dirtCommented:
Just want to let you know that I'm still working on this. I've got everything done except to get group 2 to show up in the output data.
Martin LissOlder than dirtCommented:
Let me ask you about the groups. I assume that in the Source Data that there will always be a group 1 and I see that there's also a group 2. Can there be groups 3, 4, 5, etc.? If so could there be a group 3 but no group 2?
Dmitriy KritskiyAuthor Commented:
Martin,
Yes, there is always group 1 with subgroup A at a minimum in the source data. There can be group 1 with multiple subgroups already, in that case we still want to give to user ability to add additional subgroups by just copying all As data. For example: Input 1 with A, B, C output 1 with A, B, C, D.

There could be groups 1, 2, 3, 4, 5, etc. in the source already. And yes theoretically it could be 1, 3, or 1, 4,5.
Martin LissOlder than dirtCommented:
Try this. Note that it clears the existing Output Data sheet before recreating it.

Sub ProduceOutput()

Dim lngLastRowSU As Long
Dim lngLastRowOD As Long
Dim lngRowSU As Long
Dim lngRowSD As Long
Dim lngStartRow As Long
Dim wsOD As Worksheet
Dim wsSD As Worksheet
Dim wsSU As Worksheet
Dim colGroups As New Collection
Dim intGroup As Integer

Set wsOD = Sheets("Output Data")
Set wsSD = Sheets("Source Data")
Set wsSU = Sheets("Setup")

Application.ScreenUpdating = False

wsOD.UsedRange.ClearContents

lngLastRowSU = wsSU.Range("A1048576").End(xlUp).Row
wsSD.Activate
wsSD.UsedRange.Select
' Clear any existing AutoFilters
Selection.AutoFilter
' Autofilter for the year
wsSD.UsedRange.AutoFilter Field:=1, Criteria1:=wsSU.Range("B4")

' Record the groups that exist for that year
For lngRowSD = 2 To wsSD.UsedRange.Rows.Count
    ' This adds the value and a key. Duplicate keys cause
    ' an error so only unique values are added
    On Error Resume Next
    colGroups.Add CStr(wsSD.Cells(lngRowSD, 2).Value), CStr(wsSD.Cells(lngRowSD, 2).Value)
    On Error GoTo 0
Next

' Loop through the groups. (Collections start at index 1)
For intGroup = 1 To colGroups.Count
    ' Filter for the year and group
    wsSD.UsedRange.AutoFilter
    wsSD.UsedRange.AutoFilter Field:=1, Criteria1:=wsSU.Range("B4")
    wsSD.UsedRange.AutoFilter Field:=2, Criteria1:=colGroups(intGroup)
    ' Copy the visible rows including the heading to the output sheet
    wsSD.AutoFilter.Range.Copy
    lngLastRowOD = wsOD.Range("A1048576").End(xlUp).Row
    wsOD.Activate
    If intGroup = 1 Then
        wsOD.Cells(lngLastRowOD, 1).Select
    Else
        wsOD.Cells(lngLastRowOD + 1, 1).Select
    End If
    wsOD.Paste
    If intGroup > 1 Then
        wsOD.Cells(lngLastRowOD + 1, 1).EntireRow.Delete
    End If
    
    ' Create requested new sub-groups
    For lngRowSU = 7 To lngLastRowSU
        ' See if the requested sub-group applies to the group
        If wsSD.Cells(lngRowSU, 2) = CInt(colGroups(intGroup)) Then
            lngLastRowOD = wsOD.Range("A1048576").End(xlUp).Row
            wsOD.Activate
            wsOD.Cells(lngLastRowOD + 1, 1).Select
            ' Copy the visible rows without the heading to the output sheet
            wsSD.Select
            wsSD.AutoFilter.Range.Select
            Selection.Offset(1).Resize(Selection.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
            wsOD.Activate
            wsOD.Cells(lngLastRowOD + 1, 1).Select
            wsOD.Paste
            lngStartRow = lngLastRowOD + 1
            lngLastRowOD = wsOD.Range("A1048576").End(xlUp).Row
            wsOD.Range("C" & lngStartRow & ":C" & lngLastRowOD).Value = wsSU.Cells(lngRowSU, 1)
            wsOD.Cells.AutoFilter
        End If
    Next
Next
    
wsSD.Cells.AutoFilter
Application.ScreenUpdating = True
End Sub

Open in new window

Dmitriy KritskiyAuthor Commented:
Martin, works beautifully with an exception if I am trying to add subgroups to both groups 1 and 2. Instead of adding to the 2nd the code still adds to 1st group. Please see attached:
sample-file-2.xlsm
Martin LissOlder than dirtCommented:
In my previous code a one-letter typo wsSU instead of wsSD caused what I believe was the problem, so note to self, never use variable names as similar as that. In this version I changed the names.
Sub ProduceOutput()

Dim lngLastRowSU As Long
Dim lngLastRowOD As Long
Dim lngRowSetup As Long
Dim lngRowSource As Long
Dim lngStartRow As Long
Dim wsOutput As Worksheet
Dim wsSource As Worksheet
Dim wsSetup As Worksheet
Dim colGroups As New Collection
Dim intGroup As Integer

Set wsOutput = Sheets("Output Data")
Set wsSource = Sheets("Source Data")
Set wsSetup = Sheets("Setup")

Application.ScreenUpdating = False

wsOutput.UsedRange.ClearContents

lngLastRowSU = wsSetup.Range("A1048576").End(xlUp).Row
wsSource.Activate
wsSource.UsedRange.Select
' Clear any existing AutoFilters
Selection.AutoFilter
' Autofilter for the year
wsSource.UsedRange.AutoFilter Field:=1, Criteria1:=wsSetup.Range("B4")

' Record the groups that exist for that year
For lngRowSource = 2 To wsSource.UsedRange.Rows.Count
    ' This adds the value and a key. Duplicate keys cause
    ' an error so only unique values are added
    On Error Resume Next
    colGroups.Add CStr(wsSource.Cells(lngRowSource, 2).Value), CStr(wsSource.Cells(lngRowSource, 2).Value)
    On Error GoTo 0
Next

' Loop through the groups. (Collections start at index 1)
For intGroup = 1 To colGroups.Count
    ' Filter for the year and group
    wsSource.UsedRange.AutoFilter
    wsSource.UsedRange.AutoFilter Field:=1, Criteria1:=wsSetup.Range("B4")
    wsSource.UsedRange.AutoFilter Field:=2, Criteria1:=colGroups(intGroup)
    ' Copy the visible rows including the heading to the output sheet
    wsSource.AutoFilter.Range.Copy
    lngLastRowOD = wsOutput.Range("A1048576").End(xlUp).Row
    wsOutput.Activate
    If intGroup = 1 Then
        wsOutput.Cells(lngLastRowOD, 1).Select
    Else
        wsOutput.Cells(lngLastRowOD + 1, 1).Select
    End If
    wsOutput.Paste
    If intGroup > 1 Then
        wsOutput.Cells(lngLastRowOD + 1, 1).EntireRow.Delete
    End If
    
    ' Create requested new sub-groups
    For lngRowSetup = 7 To lngLastRowSU
        ' See if the requested sub-group applies to the group
        If wsSetup.Cells(lngRowSetup, 2) = CInt(colGroups(intGroup)) Then
            lngLastRowOD = wsOutput.Range("A1048576").End(xlUp).Row
            wsOutput.Activate
            wsOutput.Cells(lngLastRowOD + 1, 1).Select
            ' Copy the visible rows without the heading to the output sheet
            wsSource.Select
            wsSource.AutoFilter.Range.Select
            Selection.Offset(1).Resize(Selection.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
            wsOutput.Activate
            wsOutput.Cells(lngLastRowOD + 1, 1).Select
            wsOutput.Paste
            lngStartRow = lngLastRowOD + 1
            lngLastRowOD = wsOutput.Range("A1048576").End(xlUp).Row
            wsOutput.Range("C" & lngStartRow & ":C" & lngLastRowOD).Value = wsSetup.Cells(lngRowSetup, 1)
            wsOutput.Cells.AutoFilter
        End If
    Next
Next
    
wsSource.Cells.AutoFilter
Application.ScreenUpdating = True
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Dmitriy KritskiyAuthor Commented:
Excellent! Thank you!
Martin LissOlder than dirtCommented:
You're welcome and I'm glad I was able to help.

In my profile you'll find links to some articles I've written that may interest you.
Marty - MVP 2009 to 2015
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.