VBA Loop through column and find value in specified range-CodePudding

Thank you in advance. New to VBA and trying to teach myself in my spare time. I am hoping someone can provide me some code to build on.

I want to loop through column K and search for each cell in columns A:I. Then I want to select the whole row and cut to another sheet. This is the code I have written, it utilized activecell but as you can imagine I would like to avoid having to click the cell I want to search for every time I execute the Macro. Especially, if I have 150 values in column K.

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

Picture of the Data Set is below.

Data Set

CodePudding user response：

Please, try the next code. Not tested, but it should work. Selecting, activating is not ta good habit. It only consumes Excel resources without bringing any benefit. Then, coloring, copying each cell/range during iteration, takes time and makes code slower. The best way is to build Union ranges and color/copy at the end of the code, at once:

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

I am leaving now my office. If something does not work as you need, or you do not understand the code, do not hesitate to ask or specify what is happening against what you need. I will be able to reply after some hours when I will be at home.