如何在VBA中自动化我的手动选择过程

Question

我有一个手动选择过程，我已经尝试过，但未能自动化，所以我正在寻求帮助。我已经附上了我的Excel表的图像作为视觉指南时，阅读我的过程。Excel快照。

我选择单元格"然后运行下面的代码。它在"A2:J1501"内查找值的第一个实例。然后剪掉整排。它将行粘贴到名为"阵容"的工作表上。然后突出显示列"L":"L"中被切割行的每个值。让我知道价值已经被使用了。然后，我手动选择下一个未突出显示的值(在图像示例中，它将是" 2")并再次运行代码，一次又一次，直到L:L的每一行都突出显示。这个过程可能需要一些时间，这取决于L:L中的行数，所以我希望我能得到一些帮助来实现自动化。

非常感谢。

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

这应该非常接近:

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

我相信这应该可以做到(更新):

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

也，我认为，比提供的其他解决方案稍微快一些(因为那里的嵌套循环?)更新:我对Tim Williams回答中的嵌套循环有点困惑，但我错过了你也想要"接受"。列表中与已删除的行匹配的值。我在更新版本中通过检查数据范围上不匹配的值是否已经转移到阵容来修复此问题。如果允许这样做，该方法将避免嵌套循环。

我在一个列表(n = 200)上检查了两种方法的速度(n = 50)，结果平均快了1.70倍…但也许速度不是那么重要，如果你是从体力劳动来的:)