How to Automate my Manual Selection Process in VBA


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

Range("A" & ActiveCell.Row).Resize(1, 10).Cut
ActiveWindow.ScrollRow = 1

nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).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
            '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
                '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)

Leave a Reply

Your email address will not be published.