VBA excel搜索多个列

我试图在多个列中搜索特定值。我下面的代码只是搜索D列。每当我修改它时，我都会得到一个错误。我想搜索列

D到M

。谢谢

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

---

我用以下方法重编了你的代码，希望对你有所帮助

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

---

这可能会让你开始

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

注:

不确定如何定义

LSearchValue

值。在这里，我明确地做到了这一点

这里我循环了100行（D1:D100）。你可以换衣服

如果您需要预先检查某个值是否大于0（如在原始代码中），则添加一条

If…

语句

我已尝试执行上述代码。我遇到的所有代码都有两个问题

While Sheets（“Sheet1”）.单元格（LSearchRow，iColumn）.Value>-1

代替

0

。 将复制数据，但由于正在粘贴重复项，因此会发生错误

当我调试时，这一行代码上出现错误

LSearchRow=LSearchRow+1

---

我无法发表评论，所以我将添加此作为答案

而Sheets（“Sheet1”）.单元格（LSearchRow，iColumn）.Value>-1起作用 而不是0。数据将被复制，但出现错误，因为 正在粘贴副本

它真的不起作用

Sheets（“Sheet1”）.Cells（LSearchRow，iColumn）.Value>-1

为所有行返回true，这就是为什么第

LSearchRow=LSearchRow+1行出现错误（实际上是“溢出”错误）

我不知道你为什么这样做。如果为空单元格设置此值，请尝试使用
Sheets（“Sheet1”）.cells（LSearchRow，iColumn）.值“”

或者代替了当。。。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

使用
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

在搜索D列到M列时，您希望多个匹配项还是单个匹配项？单个匹配项。因此，如果用户搜索账号，宏将从d:m搜索每一列。并将该账号所在的每一行复制到第2页。这与下面的Do相同，而（范围（“D”&LsearchRow））>0。这行代码在-1时工作，并生成与下面相同的错误。循环的作用是什么？假设
范围（“D”&LsearchRow）
的计算结果为
10
。这意味着您将得到一个无限循环，因为它总是>0。没有办法退出循环。
lSearchRow
是在哪里定义的？代码的目标是在行中循环。从活页1的第一行到最后一行。但是，要获取的信息位于D:M列之间（即，当找到要搜索的帐户时，它会复制该行并将其粘贴到第2页）。循环的目标是继续，直到搜索完所有行。除非我用了错误的方法，我终于想出了这个。这很好用。非常感谢大家。继续下一部分，。非常感谢大家。：）
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

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