如何在 VBA 中自动化我的手动选择过程
How to Automate my Manual Selection Process in VBA
我有一个手动 selection 过程，我已经尝试过但未能实现自动化，所以我正在寻求帮助。在阅读我的过程时，我附上了我的 Excel sheet 的图像作为视觉指南。 Excel Snapshot.
我 select 单元格“L2”和 运行 下面的代码。它在“A2:J1501”中找到值的第一个实例并剪切整行。它将行粘贴到 sheet 命名的 Lineups 上。然后它突出显示“L:L”列中剪切行的每个值，让我知道该值已被使用。然后我手动 select 下一个非突出显示的值（在图像示例中它将是“L2”）并再次 运行 代码，一次又一次，直到 [=19= 的每一行] 突出显示。这个过程可能需要一些时间，具体取决于 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
这应该非常接近：
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
我认为应该这样做（更新）：
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
另外，我认为，比提供的其他解决方案稍快（因为那里有嵌套循环？）。更新：我对蒂姆威廉姆斯的回答，但我错过了您还想“接受”列表中与已经消失的行匹配的值。我在更新版本中修复了这个问题，方法是检查在数据范围内不匹配的值是否已经传输到 Lineups。在允许的情况下，该方法避免了嵌套循环。
我在列表 (n = 200) 上检查了两种方法的速度 (n = 50) 以获得完整的数据范围，结果平均快了 1.70 倍...但也许速度并不是什么大问题, 如果你是体力劳动者:)
我有一个手动 selection 过程，我已经尝试过但未能实现自动化，所以我正在寻求帮助。在阅读我的过程时，我附上了我的 Excel sheet 的图像作为视觉指南。 Excel Snapshot.
我 select 单元格“L2”和 运行 下面的代码。它在“A2:J1501”中找到值的第一个实例并剪切整行。它将行粘贴到 sheet 命名的 Lineups 上。然后它突出显示“L:L”列中剪切行的每个值，让我知道该值已被使用。然后我手动 select 下一个非突出显示的值（在图像示例中它将是“L2”）并再次 运行 代码，一次又一次，直到 [=19= 的每一行] 突出显示。这个过程可能需要一些时间，具体取决于 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
这应该非常接近：
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
我认为应该这样做（更新）：
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
另外，我认为，比提供的其他解决方案稍快（因为那里有嵌套循环？）。更新：我对蒂姆威廉姆斯的回答，但我错过了您还想“接受”列表中与已经消失的行匹配的值。我在更新版本中修复了这个问题，方法是检查在数据范围内不匹配的值是否已经传输到 Lineups。在允许的情况下，该方法避免了嵌套循环。
我在列表 (n = 200) 上检查了两种方法的速度 (n = 50) 以获得完整的数据范围，结果平均快了 1.70 倍...但也许速度并不是什么大问题, 如果你是体力劳动者:)