Macro to copy rows based on a critera and copy the name of the column

[dreddster]

Hey Guys,

I need help with a macro to copy part of a certain rows based on criteria, then add the name of the column and the value.
The macro compares any of the values in Range E3:M1300 whether they are bigger than the value in O1.
If a match is found (for example cell F3 is bigger than O1), to copy A3:C3 on a new row in Sheet Results , on column D to copy the name of the section, and on column E to copy the actual Value.

I have included a test file with data.testexamplev2.xlsx

Thank you very much in advance!

[JOHN H. DAVIS]

Maybe:

Sub dreddster()
Dim rcell As Range
For Each rcell In Range("E3:M1300")
    If rcell.Value > Range("O1").Value Then
        Range(Cells(rcell.Row, 1), Cells(rcell.Row, 3)).Copy Sheets("Results").Range("A" & Rows.count).End(3)(2)
        Cells(2, rcell.Column).Copy Sheets("Results").Range("D" & Rows.count).End(3)(2)
        Sheets("Results").Range("E" & Rows.count).End(3)(2).Value = rcell.Value
    End If
Next rcell
End Sub

[dreddster]

Well, John...it took me more time to write my post, than you to solve it!

Works great! Thank you so much!

[JOHN H. DAVIS]

You're welcome. Glad to help out and thanks for the feedback and the rep.

[Mumps1]

I just thought that I would throw this in. The only difference is that if any changes are made to the data and you want to refresh the "Results" sheet, I think that John's macro would simply add the changes to the existing data. The following macro would avoid that issue. I'm not sure if this helps.

Sub CopyData()
    Application.ScreenUpdating = False
    Sheets("Results").Cells.ClearContents
    Sheets("Results").Range("A1") = "Number"
    Sheets("Results").Range("B1") = "Testnumber"
    Sheets("Results").Range("C1") = "Description1"
    Sheets("Results").Range("D1") = "Section"
    Sheets("Results").Range("E1") = "Amount"
    Dim rng As Range
    For Each rng In Range("E3:M1300")
        If rng > Range("O1") Then
            Range(Cells(rng.Row, 1), Cells(rng.Row, 3)).Copy Sheets("Results").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            Cells(2, rng.Column).Copy Sheets("Results").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
            rng.Copy Sheets("Results").Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
        End If
    Next rng
    Application.ScreenUpdating = True
End Sub

[dreddster]

Mumps, that's actually an awesome suggestion! This way if they press the macro button twice, it won't double the data.

Thank you very much for your addition! Now the macro is perfect!

[Mumps1]

My pleasure.

[dreddster]

Guys, one thing that came up. Where do I put .PasteSpecial xlPasteValues? Some of the cells the macro copies are formulas and I want only the result of the formulas.

[Mumps1]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Sheets("Results").Cells.ClearContents
    Sheets("Results").Range("A1") = "Number"
    Sheets("Results").Range("B1") = "Testnumber"
    Sheets("Results").Range("C1") = "Description1"
    Sheets("Results").Range("D1") = "Section"
    Sheets("Results").Range("E1") = "Amount"
    Dim rng As Range
    For Each rng In Range("E3:M1300")
        If rng > Range("O1") Then
            Range(Cells(rng.Row, 1), Cells(rng.Row, 3)).Copy
            Sheets("Results").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Cells(2, rng.Column).Copy
            Sheets("Results").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            rng.Copy
            Sheets("Results").Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next rng
    Application.ScreenUpdating = True
End Sub

[dreddster]

Works great, thank you again Mumps!

[Mumps1]

Glad it worked out.