VBA遍歷列并在指定范圍內查找值

先感謝您。VBA 新手，并嘗試在業余時間自學。我希望有人可以為我提供一些代碼來構建。

我想遍歷 K 列并搜索 A:I 列中的每個單元格。然后我想選擇整行并剪切到另一張紙。這是我撰寫的代碼，它使用了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

資料集的圖片如下。

資料集

uj5u.com熱心網友回復：

請嘗試下一個代碼。未經測驗，但它應該可以作業。選擇、激活不是一個好習慣。它只消耗 Excel 資源而沒有任何好處。然后，在迭代期間著色、復制每個單元格/范圍會花費時間并使代碼變慢。Union最好的方法是在代碼末尾立即構建范圍和顏色/復制：

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, arrExcl, 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

 ReDim arrExcl(0)
 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")): arrExcl(0) = ac.row: k = k   1
        Else
            Set rngCopy = Union(rngCopy, ws.Range("A" & ac.row, ws.cells(ac.row, "i")))
              ReDim Preserve arrExcl(k): arrExcl(UBound(arrExcl)) = ac.row: k = k   1
        End If
    End If
    Set rngExcl = ws.Range("A" & Join(arrExcl, ",A"))
    Set rngSearch = InverseIntersect(rng, 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 cel In bigRng.cells 'for discontinuous ranges
    For Each rngRow In bigRng.rows
        If Intersect(rngRow, rngExtract) Is Nothing Then
            If rng Is Nothing Then
                Set rng = rngRow
            Else
                Set rng = Union(rng, rngRow)
            End If
        End If
    Next
    Set InverseIntersect = rng
End Function

標籤：vba for循环

上一篇：For回圈創建串列

下一篇：如何在保留第一個索引值的情況下減去保留值的串列中的值