我有一個手動選擇程序，我嘗試過但未能自動化，所以我正在尋求幫助。在閱讀我的程序時，我附上了一張我的 Excel 作業表的影像作為視覺指南。Excel 快照。
我選擇單元格“L2”并運行下面的代碼。它在“A2:J1501”中找到該值的第一個實體并剪切整行。它將行粘貼到名為 Lineups 的作業表上。然后它突出顯示“L:L”列中剪切行的每個值，讓我知道該值已被使用。然后我手動選擇下一個未突出顯示的值（在影像示例中，它將是“L2”）并再次運行代碼，一次又一次，直到 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
uj5u.com熱心網友回復：
這應該非常接近：
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
uj5u.com熱心網友回復：
我相信這應該這樣做（更新）：
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 的答案中的嵌套回圈有點困惑，但我錯過了你也想“接受”串列中與已經消失的行匹配的值。我在更新版本中通過檢查與資料范圍不匹配的值是否已傳輸到 Lineups 來修復此問題。如果允許這樣做，則此方法可避免嵌套回圈。
我在一個串列 (n = 200) 上檢查了這兩種方法的速度 (n = 50) 的完整資料范圍，最終平均快了 1.70 倍......但如果你是，也許速度并不是什么大問題來自體力勞動:)
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/464234.html