Monday, September 16, 2019

Excel VBA to search for up to 15 values in one search



I am trying to run a macro which allows the user to search up to 15 values in one search. The user may sometimes only search for 1 value, but the end user wants this option to be available. The code I have right now searches for one value in Sheet1 & when found it copies the whole row to Sheet2 which works well. Now I am trying it for up to 15 values. My current code is below:




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



Try the following code. You may want to make the entry of search terms a little more robust because if they click Cancel, or enter any non-numeric value, you will get an error.



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

No comments:

Post a Comment

hard drive - Leaving bad sectors in unformatted partition?

Laptop was acting really weird, and copy and seek times were really slow, so I decided to scan the hard drive surface. I have a couple hundr...