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

例

我有电子表格（Sheet2）

我需要从我的excel表中search“Tran1”和“app”全行数据，并在searchlogging后，我需要将行复制到Sheet3中。

目前我能够做到这一点只有1logging“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." 

任何人都可以让我告诉如何使用多个search。

Answer 1

以下是您的请求可能的解决scheme：

  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 。 因此，我创build了一个for循环，循环遍历它们。 While循环中的逻辑被留下。

一般来说，你的代码使用Select ，这在VBA中是一个不好的做法，但是就其工作而言，它是可以的。 这里是如何避免select – 如何避免使用selectExcel VBAmacros

Answer 2

一个简单的使用And在你If语句将做的伎俩！

（我已经testing了“app”的B列，我会让你把它调到右边的列;））

  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, Sheet2.Range("A" & CStr(LSearchRow)).Value, "tran1") > 0 And _ InStr(1, Sheet2.Range("B" & CStr(LSearchRow)).Value, "app") > 0 Then 'Select row in Sheet2 to copy Sheet2.Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Copy 'Paste row into Sheet3 in next row Sheet3.Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Paste 'Move counter to next row LCopyToRow = LCopyToRow + 1 End If LSearchRow = LSearchRow + 1 Wend 'Position on cell A3 Application.CutCopyMode = False Sheet2.Range("A3").Select MsgBox "All matching data has been copied." Exit Sub Err_Execute: MsgBox "An error occurred." 

Answer 3

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 (ie "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