我想要一個可以找到重復項并將其回傳到單獨陣列中的鱈魚。所以我找到了一個非常適合我的代碼，但問題是這段代碼正在洗掉重復項。我以為改變它會很簡單，但不知怎的，我無法做到......
我在想它將在這部分代碼中，If Err.Number <> 0 Then coll.Remove txt但不知道如何更改它。我嘗試過更改<>，=但似乎不起作用。
有人可以告訴我應該在哪里以及如何更改代碼以從 2 個陣列中獲取重復項。
Sub test()
Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant
Dim coll As Collection
Dim I As Long, j As Long, ii As Long, txt As String, x
With Worksheets("Sheet1")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A2:C" & LastRowColumnA).Value
End With
With Worksheets("Sheet2")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = .Range("A2:C" & LastRowColumnA).Value
End With
Set coll = New Collection
On Error Resume Next
For I = LBound(arr1, 1) To UBound(arr1, 1)
txt = Join(Array(arr1(I, 1), arr1(I, 2), arr1(I, 3)), Chr(2))
coll.Add txt, txt
Next I
For I = LBound(arr2, 1) To UBound(arr2, 1)
txt = Join(Array(arr2(I, 1), arr2(I, 2), arr2(I, 3)), Chr(2))
Err.Clear
coll.Add txt, txt
If Err.Number <> 0 Then coll.Remove txt
Next I
ReDim arr3(1 To coll.Count, 1 To 3)
For I = 1 To coll.Count
x = Split(coll(I), Chr(2))
For ii = 0 To 2
arr3(I, ii 1) = x(ii)
Next
Next I
Worksheets("test").Range("A2").Resize(UBound(arr3, 1), 3).Value = arr3
Columns("A:C").EntireColumn.AutoFit
End Sub
問候， 蒂莫尼克
uj5u.com熱心網友回復：
Dim Dict as Object
Dict = CreateObject("Scripting.Dictionary")
Dim Line As Object
For Each line in MyArray
On Error Resume Next
Dict.Add(Line, "")
On Error Goto 0
Next
字典不允許重復鍵。我們只是設定鍵并通過不設定來忽略值。如果鍵存在，字典會引發錯誤。
uj5u.com熱心網友回復：
提取重復項
- 如果設定
CountSameWorksheetDuplicates為True，它將回傳每個作業表的重復項，即使在另一個作業表中找不到它們也是如此。
Option Explicit
Sub ExtractDuplicates()
Const sName1 As String = "Sheet1"
Const sCols1 As String = "A:C"
Const sfRow1 As Long = 2
Const sName2 As String = "Sheet2"
Const sCols2 As String = "A:C"
Const sfRow2 As Long = 2
Const dName As String = "Test"
Const dfCellAddress As String = "A2"
Const CountSameWorksheetDuplicates As Boolean = False
Dim Delimiter As String: Delimiter = Chr(2)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sData As Variant
sData = RefColumns(wb.Worksheets(sName1).Rows(sfRow1).Columns(sCols1))
Dim cCount As Long: cCount = UBound(sData, 2)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
Dim sKey As Variant
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
If CountSameWorksheetDuplicates Then
DictAddCount dict, sKey
Else
DictAdd dict, sKey, 1
End If
Next r
sData = RefColumns(wb.Worksheets(sName2).Rows(sfRow2).Columns(sCols2))
If CountSameWorksheetDuplicates Then
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAddCount dict, sKey
Next r
Else
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
dict2.CompareMode = vbTextCompare
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAdd dict2, sKey
Next r
For Each sKey In dict2.Keys
DictAddCount dict, sKey
Next sKey
End If
For Each sKey In dict.Keys
If dict(sKey) = 1 Then dict.Remove sKey
Next sKey
Dim drCount As Long: drCount = dict.Count
If drCount = 0 Then Exit Sub
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
r = 0
Dim c As Long
For Each sKey In dict.Keys
sData = Split(sKey, Delimiter)
r = r 1
For c = 1 To cCount
dData(r, c) = sData(c - 1)
Next c
Next sKey
Dim drg As Range
Set drg = wb.Worksheets(dName).Range(dfCellAddress).Resize(drCount, cCount)
drg.Value = dData
drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount 1) _
.Offset(drCount).Clear ' clear below
drg.EntireColumn.AutoFit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first row of a range
' ('FirstRowRange') to the row range containing
' the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal FirstRowRange As Range) _
As Range
If FirstRowRange Is Nothing Then Exit Function
With FirstRowRange.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set RefColumns = .Resize(lCell.Row - .Row 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a row of a 2D array in a delimited string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function StrJoinedDataRow( _
ByVal Data As Variant, _
ByVal RowIndex As Long, _
Optional ByVal Delimiter As String = " ") _
As String
Const ProcName As String = "StrJoinedDataRow"
On Error GoTo ClearError
Dim c As Long
Dim cString As String
For c = LBound(Data, 2) To UBound(Data, 2)
cString = cString & CStr(Data(RowIndex, c)) & Delimiter
Next c
StrJoinedDataRow = Left(cString, Len(cString) - Len(Delimiter))
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') adding another value ('Item')
' to the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAdd( _
ByRef dict As Object, _
ByVal Key As Variant, _
Optional ByVal Item As Variant = Empty)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Item
End If
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') increasing its count being held
' in the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddCount( _
ByRef dict As Object, _
ByVal Key As Variant)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = dict(Key) 1
End If
End If
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/409005.html
標籤：