Question

我有一张3张工作簿：第一张是原始数据表，然后是2张目标表。我需要一个宏来查看原始数据表中的单元格C，并根据2个值（是或否），将复制并粘贴表格2中的范围A：Y，分别为3。示例：如果在原始数据表中的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)，但这只是一个例子。

我还建议您查看How to avoid using Select in 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

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

3 个答案: