Macro to copy-paste range in row to different sheets based on specific cell value

Question

I have a workbook with 3 sheets: first one is the raw data sheet, then 2 target sheets. I would need a macro that would look at cell C in raw data sheet and based on the 2 values (YES or NO), will copy and paste the range A:Y in sheets 2, respectively 3. Example: if on C2 in raw data sheet i have YES, copy A2:Y2 and paste into sheet 2, same range A2:Y2. If instead i have the value NO, copy A2:Y2 and paste into sheet 3. Then go to next row and copy-paste A3:Y3 to sheet 2 if YES or A3:Y3 to sheet 3 if NO.

I wrote something that only works for the 2nd row, but i don't know how to make it loop... so basically when it passes to the next rows, it still copies the values from A2:Y2 to the target sheet, instead of copying A3:Y3, A4:Y4 etc.. Pasting my poor code below:

Sub IdentifyInfraction()

    Dim rngA As Range
    Dim cell As Range

    Set rngA = Range("C2", Range("C65536").End(xlUp))
    For Each cell In rngA

        Worksheets("raw_data").Select
        If cell.Value = "YES" Then
            Range("A2:Y2").Copy
            Worksheets("Value_YES").Select
            Range("A2").PasteSpecial Paste:=xlPasteValues

        ElseIf cell.Value = "NO" Then
            Range("A2:Y2").Copy
            Worksheets("Value_NO").Select
            Range("A2").PasteSpecial Paste:=xlPasteValues

        End If

    Next cell

End Sub

Please help!!! :-s

score 0 · Answer 1 · answered Jun 15 '18 at 15:35

Easiest solution would just be to replace the number 2 in each of your ranges to a variable which you then increment at the end your statement, before you go to the next cell.

For example:

Dim i = 2

Set rngA = Range("C2", Range("C65536").End(xlUp))
For Each cell In rngA

Worksheets("raw_data").Select
If cell.Value = "YES" Then
    Range("A" & i & ":Y" & i).Copy
    Worksheets("Value_YES").Select
    Range("A" & i).PasteSpecial Paste:=xlPasteValues

ElseIf cell.Value = "NO" Then
    Range("A" & i & ":Y" & i).Copy
    Worksheets("Value_NO").Select
    Range("A" & i).PasteSpecial Paste:=xlPasteValues

End If
i = i + 1
Next cell

So, originally we set i = 2, this is to go in line with your starting row of 2 mentioned in your question. Then, Range("A" & i & ":Y" & i).Copy is the same as saying Range("A2:Y2").Copy or Range("A3:Y3").Copy, etc.

This will go through any copy each row, a new row each time, and paste it to the respective row in the various sheets.

I hope this works for what you are trying to do, if not let me know.

There are a few things I'd also recommend looking into. There's a much better way to copy and paste, without going back and forward through the sheets.

ThisWorkbook.Sheets("raw_data").Rows(i).Copy Destination:=Worksheets("Value_YES").Range("A" & i)

Something like this would take the whole row from raw_data and transfer it to Value_YES. You'd have to mess around with it and change the range from Rows(i), but that's just an example.

I'd also recommend that you look into How to avoid using Select in Excel VBA to better understand why it's frowned upon to use Select and Activate in Excel VBA.

Remove the Dim should work, This code needs to paste in the next available cell, as it stands, it would only paste in row "i" — Davesexcel, Jun 15 '18 at 17:04

Davesexcel · Answer 2 · 2018-06-15T15:52:59.933

My version:

Sub GetR_Done()
    Dim rng As Range, c As Range, LstRw As Long
    Dim ws As Worksheet, Nr As Long, Yr As Long
    Dim Ys As Worksheet, Ns As Worksheet

    Set ws = Sheets("raw_data")
    Set Ys = Sheets("Value_YES")
    Set Ns = Sheets("Value_NO")

    With ws
        LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
        Set rng = .Range("C2:C" & LstRw)
        For Each c In rng.Cells
            If c = "YES" Then
                With Ys
                    Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                End With
                .Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ys.Range("A" & Yr)

            End If

            If c = "NO" Then
                With Ns
                    Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                End With
                .Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ns.Range("A" & Nr)

            End If

        Next c
    End With
End Sub

If you really require to paste values, then use this one

Sub GetR_Done()
    Dim rng As Range, c As Range, LstRw As Long
    Dim ws As Worksheet, Nr As Long, Yr As Long
    Dim Ys As Worksheet, Ns As Worksheet

    Set ws = Sheets("raw_data")
    Set Ys = Sheets("Value_YES")
    Set Ns = Sheets("Value_NO")


    Application.ScreenUpdating = False
    With ws
        LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
        Set rng = .Range("C2:C" & LstRw)
        For Each c In rng.Cells
            If c = "YES" Then
                With Ys
                    Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                End With
                .Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
                Ys.Range("A" & Yr).PasteSpecial xlPasteValues

            End If

            If c = "NO" Then
                With Ns
                    Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                End With
                .Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
                Ns.Range("A" & Nr).PasteSpecial xlPasteValues

            End If

        Next c
    End With
    Application.CutCopyMode = False
End Sub

score 0 · Answer 3 · answered Jun 17 '18 at 16:15

you could try this:

Sub IdentifyInfraction()
    Dim cell As Range

    With Worksheets("raw_data") 'reference "raw data" sheet
        For Each cell In .Range("C2", .cells(.Rows.Count, "C").End(xlUp)) ' loop through referenced sheet column C cells from row 2 down to last not empty one
            Worksheets("Value_" & cell.Value).Range(cell.Address).Resize(, 25).Value = cell.Resize(, 25).Value 'have proper target sheet A:Y current cell row values as "raw data" sheet ones
        Next
    End With
End Sub

Macro to copy-paste range in row to different sheets based on specific cell value

3 Answers3