Question

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

根据我的示例，运行宏后，我应该在第二张表中找到值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

Answer 1

不要调用子过程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

Answer 2

这应该可以解决问题：

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即可将这些值相互粘贴。

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

还要使用大量的select和activesheets，最好避免这种情况，例如参见How to avoid using Select in Excel VBA，在这种情况下，您应该使用：{{1} }

Answer 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

Answer 4

您想使用VBA而不是旧的数据透视表来执行此操作的任何特殊原因？

这是怎么回事。

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

在生成的表中选择一个单元格，然后通过选择Insert> PivotTable

将其转换为数据透视表。

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

将所有三个字段添加到ROWS区域，然后使用数据透视表中的过滤器下拉列表或通过添加切片器（根据我在此处显示的内容），根据需要过滤它们：

每次将更多数据添加到初始工作表时，只需右键单击数据透视表以刷新它以包含新数据。

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

4 个答案: