如何使用VBA从Excel中查找多个字符串并复制到另一个电子表格中

范例

我有类似的电子表格（表2）

我需要从excel工作表中搜索“Tran1”和“app”全行数据，搜索记录后，我需要将这些行复制到Sheet3中

目前，我只能为1条记录“Tran1”执行此操作，但我需要使用多个值执行此操作

以下是我的代码片段：

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer

   On Error GoTo Err_Execute
   LSearchRow = 4
   LCopyToRow = 2

   While Len(Range("A" & CStr(LSearchRow)).Value) > 0
        If InStr(1, Range("A" & CStr(LSearchRow)).Value, "tran1") > 0 Then

         'Select row in Sheet2 to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy

         'Paste row into Sheet3 in next row
         Sheet3.Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste

         'Move counter to next row
         LCopyToRow = LCopyToRow + 1

         'Go back to Sheet2 to continue searching
         Sheet2.Select

      End If
      LSearchRow = LSearchRow + 1
   Wend

   'Position on cell A3
   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub
Err_Execute:
   MsgBox "An error occurred."

---

有人能告诉我如何进行多重搜索吗？

以下是一个可能的解决方案：

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
    dim lCounter        as long 
   On Error GoTo Err_Execute
   LSearchRow = 4
   LCopyToRow = 2

    dim varValues(3)        as variant
    varValues(0) = "tran1"
    varValues(1) = "tran2"
    varValues(2) = "tran3"

   for lCounter = lbound(varValues) to ubound(varValues)

       While Len(Range("A" & CStr(LSearchRow)).Value) > 0
            If InStr(1, Range("A" & CStr(LSearchRow)).Value, varValues(0)) > 0 Then

             'Select row in Sheet2 to copy
             Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
             Selection.Copy

             'Paste row into Sheet3 in next row
             Sheet3.Select
             Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
             ActiveSheet.Paste

             'Move counter to next row
             LCopyToRow = LCopyToRow + 1

             'Go back to Sheet2 to continue searching
             Sheet2.Select

          End If
          LSearchRow = LSearchRow + 1
       Wend
   next

   'Position on cell A3
   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub
Err_Execute:
   MsgBox "An error occurred."

lCounter

和

varValues

进一步声明

varValues

获取另外两个值，

tran1

、

tran2

和

tran3

。因此，我创建了一个for循环，它在它们上面循环。While循环中的逻辑被保留

---

通常，您的代码使用

Select

，这在VBA中是一种不好的做法，但就其工作原理而言，这是可以的。以下是避免选择的方法-

以下是针对您的请求的可能解决方案：

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
    dim lCounter        as long 
   On Error GoTo Err_Execute
   LSearchRow = 4
   LCopyToRow = 2

    dim varValues(3)        as variant
    varValues(0) = "tran1"
    varValues(1) = "tran2"
    varValues(2) = "tran3"

   for lCounter = lbound(varValues) to ubound(varValues)

       While Len(Range("A" & CStr(LSearchRow)).Value) > 0
            If InStr(1, Range("A" & CStr(LSearchRow)).Value, varValues(0)) > 0 Then

             'Select row in Sheet2 to copy
             Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
             Selection.Copy

             'Paste row into Sheet3 in next row
             Sheet3.Select
             Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
             ActiveSheet.Paste

             'Move counter to next row
             LCopyToRow = LCopyToRow + 1

             'Go back to Sheet2 to continue searching
             Sheet2.Select

          End If
          LSearchRow = LSearchRow + 1
       Wend
   next

   'Position on cell A3
   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub
Err_Execute:
   MsgBox "An error occurred."

lCounter

和

varValues

进一步声明

varValues

获取另外两个值，

tran1

、

tran2

和

tran3

。因此，我创建了一个for循环，它在它们上面循环。While循环中的逻辑被保留

---

通常，您的代码使用

Select

，这在VBA中是一种不好的做法，但就其工作原理而言，这是可以的。下面是如何避免选择-

在

If

语句中简单使用

和
就可以了

（我已经为“app”测试了B列，我将让您将其调整到正确的列；）

在您的
If
语句中简单地使用
和
就可以了

（我已经为“app”测试了B列，我将让您将其调整到正确的列；）

AutoFilter（）
让事情变得简单明了：

Sub Main()
    With Sheets("Sheet2") '<--| reference "data" sheet
        With .Range("C1", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its columns A:C range from row 1 (headers) down to column A last not empty row
            .AutoFilter field:=1, Criteria1:=Array("tran1", "app"), Operator:=xlFilterValues '<--| filter referenced range on its 1st column (i.e. "Name") with "tran" and "app"
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet3").Cells(2, 1) '<--| if any filterd cells other than header then copy them and paste to Sheets("Sheet3") from its row 2
        End With
        .AutoFilterMode = False
    End With
End Sub

Sub-Main（）
使用工作表（“Sheet2”）”
AutoFilter（）
可以让事情变得非常简单和简短：

Sub Main()
    With Sheets("Sheet2") '<--| reference "data" sheet
        With .Range("C1", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its columns A:C range from row 1 (headers) down to column A last not empty row
            .AutoFilter field:=1, Criteria1:=Array("tran1", "app"), Operator:=xlFilterValues '<--| filter referenced range on its 1st column (i.e. "Name") with "tran" and "app"
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet3").Cells(2, 1) '<--| if any filterd cells other than header then copy them and paste to Sheets("Sheet3") from its row 2
        End With
        .AutoFilterMode = False
    End With
End Sub

Sub-Main（）
对于工作表（“Sheet2”），我宁愿使用VBA自动筛选功能来筛选我的记录，复制可见行并将它们粘贴到其他工作表中。这样会更快，代码行更少。我宁愿使用VBA自动筛选功能来筛选我的记录，复制可见行并将它们粘贴到其他工作表中。这将更快，并且用更少的代码行完成工作。