Excel VBA在一次search中search最多15个值
我试图运行一个macros,它允许用户在一次search中search多达15个值。 用户有时可能只search1个值,但最终用户希望此选项可用。 我现在的代码在Sheet1
search一个值,当发现它将整个行复制到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 在错误转到Err_Execute 这是为了让最终用户input所需的A / C进行search LSearchValue = InputBox(“请input要search的值”,“input值”) LCopyToRow = 2 对于rw = 1到1555 对于每个cl在范围内(“D”&rw&“:M”&rw) 如果cl = LSearchValue那么 cl.EntireRow.Copy “目标:=工作表( “Sheet2的”) '.Rows(LCopyToRow&“:”&LCopyToRow) 表( “Sheet2的”)。select 行(LCopyToRow&“:”&LCopyToRow)。select 'Selection.PasteSpecial粘贴:= xlPasteValuesAndNumberFormats Selection.PasteSpecial粘贴:= xlPasteValuesAndNumberFormats,操作:= _ xlNone,SkipBlanks:= False,Transpose:= False “将计数器移动到下一行 LCopyToRow = LCopyToRow + 1 '返回Sheet1继续search 表( “工作表Sheet1”)。select 万一 'LSearchRow = LSearchRow + 1 下一个cl 下一个rw “在单元格A3上的位置 'Application.CutCopyMode = False “Selection.Copy 表( “Sheet2的”)。select Cells.Select Selection.PasteSpecial粘贴:= xlPasteFormats,操作:= xlNone,_ SkipBlanks:= False,Transpose:= False Application.CutCopyMode = False Sheet2.Select MsgBox“所有匹配的数据已被复制”。 退出小组 Err_Execute: MsgBox“发生错误”。 结束小组
尝试下面的代码。 您可能希望使search项的input更加健壮,因为如果他们单击取消,或input任何非数字值,您将收到一个错误。
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