Excel VBA在一次搜索中最多搜索15个值

Question

我试图运行一个宏，允许用户在一次搜索中最多搜索15个值。用户有时可能只搜索1个值，但最终用户希望此选项可用。我现在的代码在sheet1中搜索一个值&找到后，它会将整行复制到sheet2，这运行良好。现在我正在尝试最多15个值。我当前的代码如下：

Sub FindValues()
   Dim LSearchRow As Integer
   Dim rw As Integer, cl As Range, LSearchValue As Long, LCopyToRow As Integer

   Sheet2.Cells.Clear
   Sheet1.Select

   On Error GoTo Err_Execute

 'this for the end user to input the required A/C to be searched

    LSearchValue = InputBox("Please enter a value to search for.", "Enter value")
    LCopyToRow = 2

    For rw = 1 To 1555
        For Each cl In Range("D" & rw & ":M" & rw)
            If cl = LSearchValue Then
                cl.EntireRow.Copy
                    'Destination:=Worksheets("Sheet2")
                    '.Rows(LCopyToRow & ":" & LCopyToRow)
                Sheets("Sheet2").Select
                Rows(LCopyToRow & ":" & LCopyToRow).Select
                    'Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                xlNone, SkipBlanks:=False, Transpose:=False
             'Move counter to next row
                LCopyToRow = LCopyToRow + 1     
             'Go back to Sheet1 to continue searching
                Sheets("Sheet1").Select  
            End If
            'LSearchRow = LSearchRow + 1

        Next cl
    Next rw

'Position on cell A3
'Application.CutCopyMode = False
'Selection.Copy

    Sheets("Sheet2").Select
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

    Sheet2.Select


    MsgBox "All matching data has been copied."


    Exit Sub

Err_Execute:

   MsgBox "An error occurred."

End Sub

Answer 1

尝试下面的代码。您可能希望使搜索项的输入更加健壮，因为如果它们单击取消或输入任何非数字值，您将得到一个错误。

Option Explicit

Sub FindValues()
Dim LSearchRow As Integer
Dim rw As Integer, cl As Range, LSearchValue As Long, LCopyToRow As Integer

Dim iHowMany     As Integer
Dim aSearch(15)  As Long
Dim i            As Integer

On Error GoTo Err_Execute

Sheet2.Cells.Clear
Sheet1.Select

 iHowMany = 0
 LSearchValue = 99

'this for the end user to input the required A/C to be searched

 Do While LSearchValue <> 0
    LSearchValue = InputBox("Please enter a value to search for. Enter a zero to indicate finished entry.", "Enter Search value")
    If LSearchValue <> 0 Then
        iHowMany = iHowMany + 1
        If iHowMany > 15 Then
            MsgBox "You are limited to 15 search numbers.", vbOKOnly, "Limit reached"
            iHowMany = 15
            Exit Do
        End If
        aSearch(iHowMany) = LSearchValue
    End If
Loop

If iHowMany = 0 Then
    MsgBox "No selections entered.", vbOKOnly + vbCritical, "No Search data"
    Exit Sub
End If

LCopyToRow = 2

For rw = 1 To 1555
    For Each cl In Range("D" & rw & ":M" & rw)
    '------------------------------------------------
        For i = 1 To iHowMany
            Debug.Print cl.Row & vbTab & cl.column
            LSearchValue = aSearch(i)
            If cl = LSearchValue Then
                cl.EntireRow.Copy

                'Destination:=Worksheets("Sheet2")
                '.Rows(LCopyToRow & ":" & LCopyToRow)

                Sheets("Sheet2").Select
                Rows(LCopyToRow & ":" & LCopyToRow).Select

                'Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                   xlNone, SkipBlanks:=False, Transpose:=False

                'Move counter to next row
                LCopyToRow = LCopyToRow + 1

                'Go back to Sheet1 to continue searching
                Sheets("Sheet1").Select
            End If
        Next i
        'LSearchRow = LSearchRow + 1
    Next cl
Next rw

'Position on cell A3
'Application.CutCopyMode = False
'Selection.Copy

Sheets("Sheet2").Select
Cells.Select

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False
Sheet2.Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred: " & Err.Number & vbTab & Err.Description
Exit Sub
Resume Next
End Sub