How to Automate my Manual Selection Process in VBA

Question

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

Answer 1

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

Answer 2

I believe this should do it (updated):

Sub AutoSelect()

Dim wsData As Worksheet, wsLineups As Worksheet
Dim rng As Range, listIDs As Range

Set wsData = ActiveWorkbook.Sheets("Data")
Set wsLineups = ActiveWorkbook.Sheets("Lineups")

Set rng = wsData.Range("A2:J1501")

'get last row col L to define list
LastRowL = wsData.Range("L" & Rows.Count).End(xlUp).Row

Set listIDs = wsData.Range("L2:L" & LastRowL)

'loop through all cells in list
For i = 1 To listIDs.Rows.Count

    myCell = listIDs.Cells(i)
    
    'retrieve first mach in listID
    checkFirst = Application.Match(myCell, listIDs, 0)
    
    'only check first duplicate in list
    If checkFirst = i Then
    
        'get new row for target sheet as well (if sheet empty, starting at two)
        newrow = wsLineups.Range("A" & Rows.Count).End(xlUp).Row + 1
    
        'check if it is already processed
        Set processedAlready = wsLineups.Cells(2, 1).Resize(newrow - 1, rng.Columns.Count).Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
    
        'if so, color yellow, and skip
        If Not processedAlready Is Nothing Then
        
            listIDs.Cells(i).Interior.Color = vbYellow
    
        Else
    
            'get fist match for value, if any (n.b. "xlWhole" ensures whole match)
            Set foundMatch = rng.Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
        
            'checking for a match
            If Not foundMatch Is Nothing Then
            
                'get the row
                foundRow = foundMatch.Row - rng.Cells(1).Row + 1
                
                'specify target range and set it equal to vals from correct row in rng
                wsLineups.Cells(newrow, 1).Resize(1, rng.Columns.Count).Value2 = rng.Rows(foundRow).Value
        
                'clear contents rng row
                rng.Rows(foundRow).ClearContents
        
                'give a color to cells that actually got a match
                listIDs.Cells(i).Interior.Color = vbYellow
        
            Else
                
                'no match
                listIDs.Cells(i).Interior.Color = vbRed
        
            End If
        
        End If

    Else

        'duplicate already handled, give same color as first
        listIDs.Cells(i).Interior.Color = listIDs.Cells(checkFirst).Interior.Color

    End If

Next i

End Sub

Also, I think, slightly faster than the other solution offered (because of the nested loop there?). Update: I got a bit confused about the nested loop in the answer by Tim Williams, but I missed that you also want to "accept" the values in the list that matched on a row that is already gone. I fixed this in the updated version by checking if a value that fails to match on the data range has already been transferred to Lineups. Provided that doing so is permissible, this method avoids the nested loop.

I checked both methods for speed (n = 50) on a list (n = 200) for the full data range, ended up with average of 1.70x faster... But maybe speed is not such a big deal, if you're coming from manual labor :)