Question

示例

我有像

这样的电子表格（Sheet2）

Spreadsheet

我需要搜索＆＃34; Tran1＆＃34;和＆＃34; app＆＃34;来自我的Excel工作表的完整行数据，在搜索记录后，我需要将行复制到Sheet3中。

目前我只能为1条记录＆＃34; Tran1＆＃34;但我需要用多个值来做。

这是我的代码段：

   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."

任何人都可以告诉我如何处理多重搜索。？

Answer 1

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

   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中是一种不好的做法，但就其工作而言，它是可以的。以下是如何避免选择 - How to avoid using Select in Excel VBA macros

Answer 2

在您And语句中简单使用If就行了！

（我已经测试了B列＆＃34; app＆＃34;，我将让您将其调到右栏;）

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

如何使用VBA

3 个答案: