Copy Rows if first cell matches criteria

[amq]

Hi everybody,

I am trying to copy a report together in a result worksheet which is based on two input worksheets.

What I have is Input_Worksheet1 which could look like

RP_ID | ER_ID | Num
rp1 | er1 | 123
rp2 | er2 | 321
rp1 | er3 | 99

Input_Worksheet2:

RP_ID | Num
rp1 | 222
rp2 | 321

The Output I am trying to achieve is

RP_ID | ER_ID | Num
rp1 | sum | 222
rp1 | er1 | 123
rp1 | er3 | 99
rp2 | sum | 321
rp2 | er2 | 321


So I am trying to create a function which
1) goes to input worksheet 2
1a) copies the first row to the output worksheet
1b) saves the value of the first cell (in column A) in a temp variable "criterion"
2) goes to input worksheet 1
2b) copies all rows to the output worksheet
2b_?) where the first cell of the row is equal to the saved variable "criterion"
3) Starts over at (1) with the 2nd row of that input worksheet

The code I have found for copying stuff is not really working with dynamic criteria and I can't seem to be able to adapt it fittingly.

Does any of you have suggestions on how to tackle this?

Thank you very much!

Best regards,
Andreas

[dangelor]

Possibly...

Sub Copy_Matching_Criteria()
    Dim x                As Long
    Dim Criterion        As Variant
    Dim c                As Range
    Dim firstAddress     As String

    '1) goes to input worksheet 2
    For x = 2 To Worksheets("Input_Worksheet2").UsedRange.Rows.Count
    
        '1a) copies the first row to the output worksheet
        Worksheets("Input_Worksheet2").Rows(x).Copy _
            Worksheets("Output").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        
        '1b) saves the value of the first cell (in column A) in a temp variable "criterion"
        Criterion = Worksheets("Output").Cells(Rows.Count, 1).End(xlUp).Value
        
        '2) goes to input worksheet 1
        With Worksheets("Input_Worksheet1").Columns(1)
        
            '2b_?) where the first cell of the row is equal to the saved variable "criterion"
            Set c = .Find(Criterion, LookIn:=xlValues)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    '2b) copies all rows to the output worksheet
                    c.EntireRow.Copy _
                        Worksheets("Output").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With
        
    '3) Starts over at (1) with the 2nd row of that input worksheet
    Next x
End Sub

[amq]

Thank you very much for your help! Problem solved :-).

[dangelor]

You're welcome! Glad it helped.