如果表中的值满足条件，则 Vba 宏从表中复制行

Question

我正在尝试制作一个宏：

1. 遍历表格
2. 查看该表 B 列中的值是否具有特定值
3. 如果有，则将该行复制到其他工作表中的范围

结果类似于过滤表格，但我想避免隐藏任何行

我对 vba 有点陌生，真的不知道从哪里开始，非常感谢任何帮助。

Answer 1

这正是您使用高级过滤器所做的。如果是一次性的，你甚至不需要宏，它可以在数据菜单中找到。

Sheets("Sheet1").Range("A1:D17").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("Sheet1").Range("G1:G2"), CopyToRange:=Range("A1:D1") _
    , Unique:=False

Answer 2

试试这样：

Sub testIt()
Dim r As Long, endRow as Long, pasteRowIndex As Long

endRow = 10 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1

For r = 1 To endRow 'Loop through sheet1 and search for your criteria

    If Cells(r, Columns("B").Column).Value = "YourCriteria" Then 'Found

            'Copy the current row
            Rows(r).Select 
            Selection.Copy

            'Switch to the sheet where you want to paste it & paste
            Sheets("Sheet2").Select
            Rows(pasteRowIndex).Select
            ActiveSheet.Paste

            'Next time you find a match, it will be pasted in a new row
            pasteRowIndex = pasteRowIndex + 1


           'Switch back to your table & continue to search for your criteria
            Sheets("Sheet1").Select  
    End If
Next r
End Sub

Answer 3

选择缓慢且不必要。下面的代码会快很多：

Sub CopyRowsAcross() 
Dim i As Integer 
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1") 
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2") 

For i = 2 To ws1.Range("B65536").End(xlUp).Row 
    If ws1.Cells(i, 2) = "Your Critera" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1) 
Next i 
End Sub 

Answer 4

您正在描述一个问题，我会尝试使用 VLOOKUP 函数而不是使用 VBA 来解决。

您应该始终首先考虑非 vba 解决方案。

以下是一些 VLOOKUP（或德语 SVERWEIS，据我所知）的应用示例：

http://www.youtube.com/watch?v=RCLUM0UMLXo

http://office.microsoft.com/en-us/excel-help/vlookup-HP005209335.aspx

---

如果您必须将其设为宏，则可以将 VLOOKUP 用作应用程序函数 - 一种性能较慢的快速解决方案 - 或者您必须自己制作一个类似的函数。

如果必须是后者，则需要有关性能问题的规范的更多详细信息。

您可以将任何范围复制到一个数组，循环遍历该数组并检查您的值，然后将该值复制到任何其他范围。这就是我将其作为 vba 函数解决的方法。

这看起来像这样：

Public Sub CopyFilter()

  Dim wks As Worksheet
  Dim avarTemp() As Variant
  'go through each worksheet
  For Each wks In ThisWorkbook.Worksheets
        avarTemp = wks.UsedRange
        For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
          'check in the first column in each row
          If avarTemp(i, LBound(avarTemp, 2)) = "XYZ" Then
            'copy cell
             targetWks.Cells(1, 1) = avarTemp(i, LBound(avarTemp, 2))
          End If
        Next i
  Next wks
End Sub

---

好的，现在我有一些不错的东西可以派上用场：

Public Function FILTER(ByRef rng As Range, ByRef lngIndex As Long) As Variant
  Dim avarTemp() As Variant
  Dim avarResult() As Variant
  Dim i As Long
  avarTemp = rng

  ReDim avarResult(0)

  For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
      If avarTemp(i, 1) = "active" Then
        avarResult(UBound(avarResult)) = avarTemp(i, lngIndex)
        'expand our result array
        ReDim Preserve avarResult(UBound(avarResult) + 1)
      End If
  Next i

  FILTER = avarResult
End Function

您可以像这样在工作表中使用它 =FILTER(Tabelle1!A:C;2) 或使用 =INDEX(FILTER(Tabelle1!A:C;2);3) 来指定结果行。我相信有人可以扩展它以将索引功能包含到 FILTER 中，或者知道如何返回一个类似对象的范围 - 也许我也可以，但今天不行；）