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