VBA 遍历列并查找指定范围内的值

Question

提前谢谢你。 VBA 的新手并尝试在业余时间自学。我希望有人可以为我提供一些代码来构建。

我想遍历 K 列并搜索 A:I 列中的每个单元格。然后我想 select 整行并切到另一个 sheet。这是我编写的代码，它使用了 activecell，但正如您想象的那样，我希望避免每次执行宏时都必须单击要搜索的单元格。特别是，如果我在 K 列中有 150 个值。

Sub Lineups()
Dim rng As Range
Set rng = Range("A2:I1501")

Dim ac As Range
Set ac = Application.ActiveCell

rng.Find(what:=ac).Select
ac.Interior.Color = 65535
Range("A" & ActiveCell.Row).Resize(1, 9).Cut
ActiveWindow.ScrollRow = 1

Sheets("Lineups").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Data").Select


End Sub

数据集图片如下。

Data Set

Answer 1

请尝试下一个代码。未经测试，但它应该工作。选择、激活不是一个好习惯。它只消耗 Excel 资源而没有带来任何好处。然后，在迭代过程中着色、复制每个 cell/range 会花费时间并使代码变慢。最好的方法是在代码末尾立即构建 Union 范围和 color/copy：

Sub Lineups()
 Dim ws As Worksheet, rng As Range, ac As Range, rngCol As Range
 Dim lastRow As Long, rngCopy As Range, arrRng, i As Long

 Set ws = ActiveSheet 'use there the sheet you want processing (probably Sheets("Data")
 'lastRow = ws.Range("K" & ws.rows.count).End(xlUp).row 'the last row in column K:K
 lastRow = 1501 'if you need last cell in K:K, uncomment the line above and comment this one
 Set rng = ws.Range("A2:H" & lastRow)

 For i = 2 To lastRow
    Set ac = rng.Find(what:=ws.Range("K" & i).value, After:=ws.Range("A2"), LookIn:=xlValues, Lookat:=xlWhole)
    If Not ac Is Nothing Then     'if a match has been found:
        If rngCol Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
            Set rngCol = ws.Range("K" & i)
        Else
            Set rngCol = Union(rngCol, ws.Range("K" & i))
        End If
        If rngCopy Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
            Set rngCopy = ws.Range("A" & ac.row, ws.cells(ac.row, "i"))
        Else
            Set rngCopy = Union(rngCopy, ws.Range("A" & ac.row, ws.cells(ac.row, "i")))
        End If
    End If
 Next i
 If Not rngCol Is Nothing Then rngCol.Interior.Color = 65535 ' color the interior of the matching cells in K:K

 'Copy the necessary range in sheet "Lineups" and clear the copied range:
 Dim wsL As Worksheet, nextRow As Long
 Set wsL = Sheets("Lineups")

 nextRow = wsL.cells(rows.count, 1).End(xlUp).row + 1
 If Not rngCopy Is Nothing Then 'if at least a match has been found:
     rngCopy.Copy wsL.cells(nextRow, 1) 'copy the union range at once
     rngCopy.ClearContents              'clear contents of the union range at once
 End If
End Sub

我现在要离开我的办公室了。如果某些东西不能按您的需要工作，或者您不理解代码，请毫不犹豫地询问或说明您需要的是什么。我会在几个小时后在家回复。

已编辑:

请测试下一个版本并发送一些反馈：

Sub Lineups_()
 Dim ws As Worksheet, rng As Range, rngSearch As Range, ac As Range, rngCol As Range
 Dim lastRow As Long, rngCopy As Range, rngExcl As Range, i As Long, k As Long

 Set ws = ActiveSheet 'use there the sheet you want processing (probably Sheets("Data")
 lastRow = ws.Range("K" & ws.Rows.Count).End(xlUp).Row 'the last row in column K:K
 ws.Range("K2:K" & lastRow).Interior.Color = xlNone 'clear interior color to see the changes (you can comment it, if not  necessary)
 Set rng = ws.Range("A2:H1501")
 Set rngSearch = rng 'set a so named search range, adapted by excluding of processed rows

 For i = 2 To lastRow
    Set ac = rngSearch.Find(what:=ws.Range("K" & i).Value, After:=rngSearch.Cells(1, 1), LookIn:=xlValues, Lookat:=xlWhole)
    If Not ac Is Nothing Then      'if a match has been found:
        If rngCol Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
            Set rngCol = ws.Range("K" & i)
        Else
            Set rngCol = Union(rngCol, ws.Range("K" & i))
        End If
        If rngCopy Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
            Set rngCopy = ws.Range("A" & ac.Row, ws.Cells(ac.Row, "i")):
            Set rngExcl = ws.Range("A" & ac.Row) 'set the range to be excluded
        Else
            Set rngCopy = Union(rngCopy, ws.Range("A" & ac.Row, ws.Cells(ac.Row, "i")))
              Set rngExcl = Union(rngExcl, ws.Range("A" & ac.Row)) 'build the range to be excluded
        End If
    End If
    'build the string where to search for:
    Set rngSearch = InverseIntersect(rngSearch, rngExcl.EntireRow)
 Next i
 If Not rngCol Is Nothing Then rngCol.Interior.Color = 65535 ' color the interior of the matching cells in K:K

 'Copy the necessary range in sheet "Lineups" and clear the copied range:
 Dim wsL As Worksheet, nextRow As Long
 Set wsL = ws.Next ' Sheets("Lineups")

 nextRow = wsL.Cells(Rows.Count, 1).End(xlUp).Row + 1
 If Not rngCopy Is Nothing Then 'if at least a match has been found:
     rngCopy.Copy wsL.Cells(nextRow, 1) 'copy the union range at once
     rngCopy.ClearContents                   'clear contents of the union range at once
 End If
 MsgBox "Ready..."
End Sub

Function InverseIntersect(bigRng As Range, rngExtract As Range) As Range
    Dim rng As Range, rngRow As Range

    For Each rngRow In bigRng.rows 'iterate between the range to be processed rows:
        If Intersect(rngRow, rngExtract) Is Nothing Then 'if iterated row intersects with range to be extracted:
                                                                         'creates a range only from rows which do not intersect
            If rng Is Nothing Then                       'Set the range as the current row
                Set rng = rngRow
            Else
                Set rng = Union(rng, rngRow)             'creates a Union between the previous existing range and the current row
            End If
        End If
    Next
    Set InverseIntersect = rng                           'set the function as the newly created range
End Function

VBA 遍历列并查找指定范围内的值

VBA Loop through column and find value in specified range

vba

for-loop