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

Question

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

Answer 1

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.
Edited:
Please, test the next version and send some feedback:
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