我有一個 vba 宏，用于檢查 A 列中是否存在重復項并檢查 B 列中是否存在某個值，但想知道是否有辦法將其轉換為與陣列一起使用。當前代碼運行良好，但我遇到了一個包含超過 153,000 行的檔案，并且運行宏需要幾個小時。
我可以讓它用陣列在 A 列中查找重復項，但無法弄清楚如何檢查它是否與 B 列中的某個值匹配。
這就是我想要它做的：
如果匹配：
如果不匹配：
這是我現在找到不使用陣列的重復項的代碼：
Dim cell As Range
Dim wbook As Workbook
Dim wsheet As Worksheet
Dim sname As Range
Dim cname As Range
Dim rngA As Range
Dim dupA As Range
Dim dupB As Range
Dim strName As String
Set wbook = ActiveWorkbook 'Current Workbook
Set wsheet = Sheets("OFA_CP_OUT_202112_Without_Match") 'Worksheet Name
Set sname = Range("A2:H2426") 'Range for sorting and aligning columns A:H
Set cname = Sheets("OFA_CP_OUT_202112_Without_Match").Range("F2:F2426") 'Sheet Name & Range to format currency
Set rngA = Range("A2:A2426") 'Range to change column A to uppercase & find if a cell contains an A, B or S
Set dupA = wsheet.Range("A2:A2426") 'Range to find duplicates in column A
Set dupB = wsheet.Range("B2:B2426") 'Range to find year & month in column B (ex: 202112)
strName = "202112" 'year & month to search for in column B
'Looks for duplicates and highlights them yellow in column A & column B
For Each cell In dupA
If WorksheetFunction.CountIfs(dupA, "=" & cell.Value, dupB, "=" & cell.Offset(0, 1).Value) > 1 Then
cell.Interior.ColorIndex = 6
cell.Offset(0, 1).Interior.ColorIndex = 6
End If
Next cell
這是我使用陣列查找重復項的代碼：
Sub Dupes()
Dim Ws As Worksheet
Dim LastRow As Long, i As Long, j As Long, DupCounter As Long, DupPos As Long
Dim MatNo As String
Dim Found As Boolean
Dim ArrDuplicates() As Variant 'Declare dynamic array
Set Ws = ThisWorkbook.Sheets(1)
'Redimennsion/change size of declared array
ReDim ArrDuplicates(1 To 2, 1 To 1)
DupCounter = 1
With Ws
'find last row with data in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'Loop all rows from 1 to last
For i = 1 To LastRow
'reset variables for each loop
Found = False
DupPos = 0
MatNo = .Cells(i, 1)
'Search array with previous data and look for duplicates
For j = LBound(ArrDuplicates(), 2) To UBound(ArrDuplicates(), 2)
'If material number currently checked found in array
If MatNo = ArrDuplicates(1, j) Then
'remember position of source data in array (first occurence
'of material number)
DupPos = j
'set "Found" marker
Found = True
'leave loop
Exit For
End If
Next j
'if no duplicate found
If Not Found Then
'redimension array. "Preserve" keyword added to keep values
'already existing in array
ReDim Preserve ArrDuplicates(1 To 2, 1 To DupCounter)
'insert new data to array ((first occurance of material number)
ArrDuplicates(1, DupCounter) = MatNo
DupCounter = DupCounter 1 'increase counter used to redimension array
Else 'if material number found in array
'change font color
.Cells(i, 1).Font.Color = vbRed
End If
Next i
End With
End Sub
謝謝你的幫助！
uj5u.com熱心網友回復：
這應該更快：
Sub FlagDups()
Dim wb As Workbook, wsheet As Worksheet
Dim dupA As Range, arrA, dupB As Range, arrB
Dim dict As Object, i As Long, k, rng As Range
Set dict = CreateObject("scripting.dictionary")
Set wb = ActiveWorkbook
Set wsheet = wb.Worksheets("OFA_CP_OUT_202112_Without_Match")
Set dict = CreateObject("scripting.dictionary")
Set dupA = wsheet.Range("A2:A2426") 'Range to find duplicates in column A
Set dupB = wsheet.Range("B2:B2426") 'Range to find year & month in column B (ex: 202112)
arrA = dupA.Value 'read all the data
arrB = dupB.Value
wsheet.Range("A1:B10000").Interior.ColorIndex = xlNone 'clear any existing fill
For i = LBound(arrA) To UBound(arrA) 'loop over the data arrays
k = arrA(i, 1) & Chr(0) & arrB(i, 1) 'composite key from A, B
If Not dict.exists(k) Then
dict.Add k, i 'novel pair of values: store row index
Else
If dict(k) > 0 Then 'need to process store row index?
addCell rng, dupA.Cells(dict(k)) 'collect the first instance of this pair
addCell rng, dupB.Cells(dict(k))
dict(k) = 0 'flag as collected
End If
addCell rng, dupA.Cells(i) 'collect current instance
addCell rng, dupB.Cells(i)
End If
Next i
If Not rng Is Nothing Then rng.Interior.Color = vbYellow 'any cells to color?
End Sub
'build a range by adding rngAdd to rngTot
Sub addCell(rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/442145.html