I have a manual selection process that I have tried but failed to automate, so I am reaching out for help. I have attached an image of my Excel sheet as a visual guide when reading my process. Excel Snapshot.
I select cell "L2" and run the code below. It finds the first instance of the value within "A2:J1501" and cuts the whole row. It pastes the row onto the sheet named Lineups. Then it highlights each of the values of the cut row in column "L:L" to let me know that value has been used. I then manually select the next non-highlighted value (in the image example it would be "L2") and run the code again, and again, and again, until every row of L:L is highlighted. This process can take some time depending on the number of rows in L:L so I was hoping I can get some help to automate.
Thank you very much.
Sub ManualSelect() Dim rng As Range Set rng = Range("A1:J1501") Dim ac As Range Set ac = Application.ActiveCell rng.Find(what:=ac).Select Range("A" & ActiveCell.Row).Resize(1, 10).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 Dim wsData As Worksheet Dim wsLineups As Worksheet Dim rngToSearch As Range Dim rngLineupSet As Range Dim rngPlayerID As Range Dim Column As Long Dim Row As Long Dim LastRow As Long Set wsData = Sheets("Data") Set wsLineups = Sheets("Lineups") Set rngPlayerID = wsData.Range("L2:K200") Set rngToSearch = rngPlayerID LastRow = wsLineups.Cells(Rows.Count, 1).End(xlUp).Row For Row = 2 To LastRow For Column = 1 To 10 Set rngLineupSet = rngPlayerID.Find(what:=wsLineups.Cells(Row, Column), LookIn:=xlValues) If Not rngLineupSet Is Nothing Then rngLineupSet.Interior.Color = 65535 Next Column Next Row End Sub
This should be pretty close:
Sub ManualSelect() Dim wsData As Worksheet, c As Range, dict As Object, v, rw As Range Dim wsLineups As Worksheet, c2 As Range, f As Range Set dict = CreateObject("scripting.dictionary") 'for tracking already-seen values Set wsLineups = ThisWorkbook.Worksheets("Lineups") Set wsData = ThisWorkbook.Worksheets("Data") For Each c In wsData.Range("L2", wsData.Cells(Rows.Count, "L").End(xlUp)) v = c.Value If dict.exists(CStr(v)) Then c.Interior.Color = vbYellow 'already seen this value in L or a data row Else 'search for the value in Set f = wsData.Range("A2:J1501").Find(v, lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows) If Not f Is Nothing Then Set rw = f.EntireRow.Columns("A").Resize(1, 10) 'A to J For Each c2 In rw.Cells 'add all values from this row to the dictionary dict(CStr(c2)) = True Next c2 rw.Cut Destination:=wsLineups.Cells(Rows.Count, "A").End(xlUp).Offset(1) c.Interior.Color = vbYellow Else 'will there always be a match? c.Interior.Color = vbRed 'flag no matching row End If End If 'haven't already seen this col L value Next c 'next Col L value End Sub
Answered By – Tim Williams
Answer Checked By – Terry (AngularFixing Volunteer)