如果满足多个条件，VBA 复制数据答案

【问题标题】：VBA to copy data if multiple criteria are met如果满足多个条件，VBA 复制数据
【发布时间】：2018-07-06 13:11:11
【问题描述】：

我正在尝试创建一个 VBA 代码，当满足第一列中的“Lukas”和第二列中的“Apple”标准时，它将下面选项卡第三列中的数据复制到工作表“结果”中。我知道这可以仅使用具有多个条件的 VLOOKUP 来完成，但数据源长度通常会发生变化，我需要宏从第 2 行到最后一个可见行进行检查。

根据我的示例，我应该在运行宏后在第二张表中找到值 8 和 5。以下是我一直在编写的代码，但是它不起作用..

    Sub copy()

Dim LastRow As Long
Dim i As Long

LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Worksheets("Sheet1").Cells(i, 1) = "Lukas" And Worksheets("Sheet1").Cells(i, 2) = “Apple” Then
 Worksheets("Sheet1").Cells(i, 3).Select
 Selection.copy
 Sheets("Sheet2").Select
 Range(Cells(1, 1)).PasteSpecial xlPasteValues

End If
Next i

End Sub

【问题讨论】：

对不起，我的意思是结果中的 8 和 5
您的问题左下角有一个编辑按钮。
您还应该更改 Apple 周围的引号

标签： vba excel

【解决方案1】：

这应该可以解决问题：

Sub Selectivecopy()

Dim LastRow As Long
Dim i As Long
Dim j As Long

LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

j = 1
For i = 2 To LastRow

If Worksheets("Sheet1").Cells(i, 1) = "Lukas" And Worksheets("Sheet1").Cells(i, 2) = "Apple" Then
     Worksheets("Sheet2").Cells(j,1) = worksheets("Sheet1").Cells(i,3).Value
     j = j +1
End If
Next i

End Sub

您可以直接设置单元格的值，使用此行：Worksheets("Sheet2").Cells(j,1) = worksheets("Sheet1").Cells(i,3).Value。每次执行此操作时，只需递增 j，即可将值粘贴到彼此下方。

如果您希望在第二次运行代码时在最后一个单元格下继续此操作，您还必须将 j = 1 替换为工作表 2 的 lastrow 方法。

另外你使用了很多select和activesheets，最好避免这种情况，例如看：How to avoid using Select in Excel VBA，在你的情况下你应该使用：Lastrow = Worksheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row

【讨论】：

我只是在 VBE 要求我将其声明为变量时添加 Option Explicit 才发现它（尽管 +1）
明确添加选项总是好的。我什至没有把它放到 VBA 中，所以这就是你抓住我的地方；）

【解决方案2】：

不要调用您的子过程 Copy()。把它称为任何东西。

选择不同的目的地，否则您将覆盖您正在传输的值。

Sub copyLukasAndApple()

    Dim LastRow As Long, i As Long, ws2 as worksheet

    with Worksheets("Sheet1")
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row

        For i = 2 To LastRow

            If .Cells(i, 1) = "Lukas" And .Cells(i, 2) = “Apple” Then
                with workSheets("Sheet2")
                    .cells(.rows.count, "A").end(xlup).offset(1, 0) = _
                         Worksheets("Sheet1").Cells(i, 3).value
                end with
            End If

        Next i
    end with

End Sub

【讨论】：

避免第二个柜台的优雅方式。

【解决方案3】：

我发布这个只是因为它使用了一种不同的方法，自动筛选，所以你可以一举完成。

Sub x()

Dim r As Range

Application.ScreenUpdating = False

With Worksheets("Sheet1")
    .AutoFilterMode = False
    .Range("A1").AutoFilter Field:=1, Criteria1:="=Lukas"
    .Range("A1").AutoFilter Field:=2, Criteria1:="=apple"
    With .AutoFilter.Range
        On Error Resume Next
        Set r = .Resize(.Rows.Count - 1, 1).Offset(1, 2).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not r Is Nothing Then
            r.copy Worksheets("Sheet2").Range("A1")
        End If
    End With
    .AutoFilterMode = False
End With

Application.ScreenUpdating = True

End Sub

【讨论】：

也不错。当要复制的行变成数千行时，可能会节省时间。
@Luuklag - 谢谢。确实如此，尽管根据我的经验，除非您拥有大量数据，否则循环通常是可以的。
顺便说一句，您应该在偏移之前调整大小。例如Set r = .Resize(.Rows.Count - 1, 1).Offset(1, 2).... 如果过滤器范围错误地进入工作表的底部（例如 Range("A:C").AutoFilter），则先放置偏移量会崩溃。这种情况很少见，但我们在这里遇到过几次这样的问题，而且几乎无法诊断。

【解决方案4】：

您有什么特别的原因想要使用 VBA，而不是一个好的旧数据透视表？

方法如下。

在您的范围内选择一个单元格，然后使用 Ctrl+T 键盘快捷键将其转换为 Excel 表格：

在结果表中选择一个单元格，然后通过选择插入>数据透视表将其转换为数据透视表

这会在新工作表上为您提供一个空的数据透视表“画布”：

将所有三个字段添加到 ROWS 区域，并根据需要使用数据透视表中的过滤器下拉菜单过滤它们，或者通过添加切片器，如下所示：

每当您向初始工作表添加更多数据时，只需右键单击数据透视表即可刷新它以包含新数据。

【讨论】：