[英]VBA excel search multiple columns
I am trying to search through multiple columns for a particular value. 我正在尝试通过多个列搜索特定的值。 The code I have below is only searching column D. Whenever I alter it I get an error.
我下面的代码仅在D列中搜索。每当我更改它时,都会出现错误。 I want to search columns
D to M
. 我想搜索
D to M
列。 Thanks 谢谢
Do While (Range("D" & CStr(LSearchRow)).Value) > 0
'If value in column D = LSearchValue, copy entire row to Sheet2
If Range("D" & CStr(LSearchRow)).Value = LSearchValue Then
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.PasteSpecial
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Loop
I redid your code in the following way, I hope you will find it helpful. 我通过以下方式重新编写了您的代码,希望对您有所帮助。
Sub searchValue()
Dim LSearchValue As String
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim iColumn As Integer
'I'm looking for string = "5", change it to your value or pass it through procedure parameter
LSearchValue = "5"
LCopyToRow = 1
For iColumn = 4 To 13
LSearchRow = 1
While Sheets("Sheet1").Cells(LSearchRow, iColumn).Value > 0
If Sheets("Sheet1").Cells(LSearchRow, iColumn).Value = LSearchValue Then
'Select row in Sheet1 to copy
Rows(LSearchRow).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(LCopyToRow).Select
ActiveSheet.PasteSpecial
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
Next iColumn
End Sub
This might get you started. 这可能会让您入门。
Sub FindValues()
Dim rw As Integer, cl As Range, LSearchValue As Long, LCopyToRow As Integer
LCopyToRow = 1
LSearchValue = 10
For rw = 1 To 100
For Each cl In Range("D" & rw & ":M" & rw)
If cl = LSearchValue Then
cl.EntireRow.Copy Destination:=Worksheets("Sheet2").Rows(LCopyToRow & ":" & LCopyToRow)
LCopyToRow = LCopyToRow + 1
End If
Next cl
Next rw
End Sub
Note: 注意:
LSearchValue
value. LSearchValue
值。 Here I do it explicitly. If...
statement If...
语句 Sub searchValue()
Dim LSearchValue As String`
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim iColumn As Integer
Sheet2.Cells.Clear
Sheet1.Select
On Error GoTo Err_Execute
'user inputs value to be found
LSearchValue = InputBox("Please enter a value to search for.", "Enter value")
LCopyToRow = 1
For iColumn = 4 To 13
LSearchRow = 1
While Sheets("Sheet1").Cells(LSearchRow, iColumn).Value > -1
If Sheets("Sheet1").Cells(LSearchRow, iColumn).Value = LSearchValue Then
'Select row in Sheet1 to copy
Rows(LSearchRow).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
Next iColumn
'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
I have tried to implement the above codes. 我试图实现以上代码。 All the codes I have experienced two issues.
我所有的代码都遇到了两个问题。
While Sheets("Sheet1").Cells(LSearchRow, iColumn).Value > -1
works instead of 0
. While Sheets("Sheet1").Cells(LSearchRow, iColumn).Value > -1
代替0
起作用。 the data will be copied over but an error occurs because duplicates are being pasted. 数据将被复制但由于粘贴重复项而发生错误。
When I debug, an error is occurring on this line of code LSearchRow = LSearchRow + 1
当我调试时,这行代码
LSearchRow = LSearchRow + 1
发生错误
I can't comment so I'm adding this as an answer. 我无法发表评论,因此我将其添加为答案。
While Sheets("Sheet1").Cells(LSearchRow, iColumn).Value > -1 works instead of 0. the data will be copied over but an error occurs because duplicates are being pasted.
虽然Sheets(“ Sheet1”)。Cells(LSearchRow,iColumn).Value> -1代替0起作用。数据将被复制,但是由于粘贴重复项而发生错误。
It's not working really. 确实没有用。
Sheets("Sheet1").Cells(LSearchRow, iColumn).Value > -1
is returning true for all your rows, that is why you are getting error on line LSearchRow = LSearchRow + 1
(actually it is 'overflow' error). Sheets("Sheet1").Cells(LSearchRow, iColumn).Value > -1
对所有行都返回true,这就是为什么在行LSearchRow = LSearchRow + 1
出错(实际上是“溢出”错误)的原因。
I don't know why you're doing such condition. 我不知道你为什么要这样做。 If this if for empty cells try
Sheets("Sheet1").Cells(LSearchRow, iColumn).Value <> ""
instead? 如果这对于空单元格,请尝试使用
Sheets("Sheet1").Cells(LSearchRow, iColumn).Value <> ""
代替吗?
Or instead of While ... Wend you can do something like this: 或代替While ... Wend您可以执行以下操作:
Dim i as Long
For i=1 to Sheet("Sheet1").Cells(1,iColumn).End(xlDown).Row 'looping from first cell in column 'iColumn' to last not empty cell
...
Next i
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
Using the Find()
method will be the most efficient method of finding matching values. 使用
Find()
方法将是查找匹配值的最有效方法。
Sub Find_Value()
Dim lFirstMatch As Long
Dim rngSearch As Range
Dim rngNextRow As Range
Dim sSearchValue As String
'Set the Search Value
sSearchValue = "Something"
'Find the Search Value
Set rngSearch = Sheets("Sheet1").Range("D:M").Find(What:=sSearchValue, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rngSearch Is Nothing Then
'If found preserve the first row
lFirstMatch = rngSearch.Row
Do
'Find the last used row on Sheet2
Set rngNextRow = Sheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If Not rngNextRow Is Nothing Then
'If a last used row is found, copy the row from Sheet1 to the next available row on Sheet2
rngSearch.EntireRow.Copy Destination:=rngNextRow.Offset(1, 0).EntireRow
Else
'If a last used row is not found, copy the row from Sheet1 to the first row on Sheet2
rngSearch.EntireRow.Copy Destination:=Sheets("Sheet2").Rows(1)
End If
'Find the next value on Sheet1
Set rngSearch = Sheets("Sheet1").Range("D:M").Find(What:=sSearchValue, LookAt:=xlWhole, After:=rngSearch, SearchOrder:=xlByRows)
'Stop looking for the Search Value once you have come full circle back to the first value
Loop While Not rngSearch.Row = lFirstMatch
End If
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.