宏根据特定的单元格值将行粘贴范围复制到不同的工作表中

Question

我有一本包含3张纸的工作簿：第一个是原始数据表，然后是2个目标表。 我需要一个宏，该宏将查看原始数据表中的单元格C，并基于2个值（是或否）分别复制并粘贴工作表2中3的范围A：Y。示例：如果在原始数据中的C2上数据表我有，复制A2：Y2并粘贴到工作表2中，相同范围A2：Y2。 如果我的值为NO，则复制A2：Y2并粘贴到工作表3中。然后转到下一行，如果是，则将A3：Y3复制并粘贴到工作表2上，如果不是，则将A3：Y3复制并粘贴到工作表3中。

我写了一些仅适用于第二行的内容，但我不知道如何使其循环...因此基本上，当它传递到下一行时，它仍然将值从A2：Y2复制到目标工作表，而不是复制A3：Y3，A4：Y4等。在下面粘贴我的可怜代码：

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

请帮忙！！！ ：-s

Answer 1

最简单的解决方案是将每个范围中的数字2替换为变量，然后在转到下一个单元格之前在语句的末尾递增。

例如：

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

因此，最初我们将i = 2设置为与问题中提到的起始行2 。 然后， Range("A" & i & ":Y" & i).Copy于说Range("A2:Y2").Copy或Range("A3:Y3").Copy等。

这将遍历每行的任何副本，每次遍历新行，并将其粘贴到各个工作表的相应行中。

我希望这对您尝试做的事情有效，如果没有让我知道。

---

我还建议您注意一些事项。 有一种更好的复制和粘贴方法，而无需在图纸之间来回移动。

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

这样的事情会把raw_data的整个行转移到Value_YES 。 您必须弄乱它并更改Rows(i)的范围，但这只是一个例子。

我还建议您研究如何避免在Excel VBA中使用“选择”，以更好地理解为什么在Excel VBA中使用“选择并激活”的原因。

Answer 2

我的版本：

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

---

如果您确实需要粘贴值，请使用此值

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

Answer 3

您可以尝试以下方法：

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