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

1 回答

• 2

  请尝试以下代码 . 您可能希望使搜索项的输入更加健壮，因为如果他们单击“取消”或输入任何非数字值，您将收到错误 .

  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
  

  回复于 2024-05-15T19:13:40+08:00