宏根據特定的單元格值將行粘貼范圍復制到不同的工作表中

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