从数组中删除重复项 - vba

Question

我有一个代码，它从文件的列中获取数据，并将其放入数组中。

现在，我想遍历这个数组并删除重复项，但我无法让它通过...有什么想法吗？

这是代码，数组在最后：

Dim i As Long
Dim searchItem As Variant
strSearch = ""
searchItem = "" 
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
    For i = 1 To Rows.Count
        If Not IsEmpty(Cells(i, 1).Value) Then
           strSearch = strSearch & "," & Cells(i, 1).Value
        End If
    Next i
End With
s_wbk.Close
searchItem = Split(strSearch, ",") '*NEED TO REMOVE DUPLICATES

Answer 1

在字符串构造过程中通过使用InStr function 测试之前的存在来删除重复项。

    If Not IsEmpty(Cells(i, 1).Value) And _
      Not InStr(1, strSearch, Cells(i, 1).Value & ",", vbTextCompare) Then
       strSearch = strSearch & "," & Cells(i, 1).Value
    End If

您还应该在拆分之前删除最后一个尾随逗号。

Next i
strSearch = Left(strSearch, Len(strSearch) - 1)

最后，如果您已将值添加到 Scripting.Dictionary 对象（它带有自己的唯一主键索引），您将在已经为您构建的数组中拥有一组唯一键。

Answer 2

这对我有用：

Function removeDuplicates(ByVal myArray As Variant) As Variant

Dim d As Object
Dim v As Variant 'Value for function
Dim outputArray() As Variant
Dim i As Integer

Set d = CreateObject("Scripting.Dictionary")

For i = LBound(myArray) To UBound(myArray)

    d(myArray(i)) = 1

Next i

i = 0
For Each v In d.Keys()

    ReDim Preserve outputArray(0 To i)
    outputArray(i) = v
    i = i + 1

Next v

removeDuplicates = outputArray

End Function

希望对你有帮助

Answer 3

最简单的方法是复制您输入的工作表并使用内置函数来消除重复项，看看这个：

Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet

strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)

With Ws
    'Remove duplicates from column A
    With .Range("A:A")
        .Value = .Value
        .RemoveDuplicates _
            Columns:=Array(1), _
            Header:=xlNo
    End With
    For i = 1 To .Range("A" & .Rows.count).End(xlUp).Row
        If Not IsEmpty(.Cells(i, 1)) Then
           strSearch = strSearch & "," & .Cells(i, 1).Value
        End If
    Next i
    'Get rid of that new sheet
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = False
End With

s_wbk.Close
searchItem = Split(strSearch, ",") 'NO MORE DUPLICATES ;)

或者更快（因为RemoveDuplicates之后的范围内不会有空单元格）：

Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet

strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)

With Ws
    'Remove duplicates from column A
    With .Range("A:A")
        .Value = .Value
        .RemoveDuplicates _
            Columns:=Array(1), _
            Header:=xlNo
    End With

    'NO MORE DUPLICATES  and FASTER ARRAY FILL ;)
    searchItem = .Range(.Range("A1"), .Range("A" & .Rows.count).End(xlUp)).Value

    'Get rid of that new sheet
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = False
End With

s_wbk.Close

Answer 4

通常我使用字典对象来检查重复项，或者使用它本身。字典是引用值的唯一键的对象。由于键必须是唯一的，因此对于收集唯一值非常有用。也许它不是最有效的内存方式，并且可能对对象有一点滥用，但它工作得很好。 您必须使对象变暗并将其设置为字典，收集数据，检查它不存在后，然后循环遍历字典以收集值。

Dim i As Long
Dim searchItem As Variant, var as variant
dim dicUniques as object

set dicUniques = CreateObject("Scripting.Dictionary")
strSearch = ""
searchItem = "" 
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
    For i = 1 To Rows.Count
        If Not IsEmpty(Cells(i, 1).Value) Then
           if dicUniques.exists(cells(i,1).value) = false then
              dicUniques.add cells(i,1).value, cells(i,1).value
           end if
        End If
    Next i
End With
s_wbk.Close

for each var in dicUniques.keys
   strSearch = strSearch & ", " & var
next var
searchItem = Split(strSearch, ",")

这是快速而肮脏的解决方案。由于键是唯一的，您可以自己使用它们，而无需先将它们放在字符串中。 顺便说一句：首先，您应该指定使用哪些单元格。有时您从另一个工作表开始宏，然后如果没有为单元格对象提供父工作表，它将使用那里的单元格。 其次，指定要使用字典的单元格值很重要，因为字典对象可以包含任何内容。因此，如果您不使用 cells(x,y).value，则该对象将包含单元格本身。

编辑：更正了例程中的错字。

Answer 5

数组的唯一列

Option Explicit

Sub removeDuplicates()

    Const strFile = "...\Desktop\xl files min\src.xlsm"
    Const SheetName As String = "Sheet1"
    Const SourceColumn As Variant = 1   ' e.g. 1 or "A"
    Const FirstRow As Long = 2

    Dim s_wbk As Workbook
    Dim SourceArray, WorkArray, searchItem

    Set s_wbk = Workbooks.Open(strFile)
        SourceArray = copyColumnToArray(s_wbk.Worksheets(SheetName), _
          FirstRow, SourceColumn)
    s_wbk.Close
    If Not IsArray(SourceArray) Then Exit Sub
    WorkArray = Application.Transpose(SourceArray) ' only up to 65536 elements.
    searchItem = getUniqueArray(WorkArray)

End Sub

Function copyColumnToArray(SourceSheet As Worksheet, _
  FirstRowNumber As Long, ColumnNumberLetter As Variant) As Variant

    Dim rng As Range
    Dim LastRowNumber As Long

    Set rng = SourceSheet.Columns(ColumnNumberLetter).Find(What:="*", _
      LookIn:=xlFormulas, Searchdirection:=xlPrevious)
    If rng Is Nothing Then Exit Function
    Set rng = SourceSheet.Range(SourceSheet _
      .Cells(FirstRowNumber, ColumnNumberLetter), rng)
    If Not rng Is Nothing Then copyColumnToArray = rng

End Function

Function getUniqueArray(SourceArray As Variant, _
  Optional Transpose65536 As Boolean = False) As Variant

    ' Either Late Binding ...
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    ' ... or Early Binding:
    ' VBE > Tools > References > Microsoft Scripting Runtime
    'Dim dict As Scripting.Dictionary: Set dict = New Scripting.Dictionary

    Dim i As Long

    For i = LBound(SourceArray) To UBound(SourceArray)
        If SourceArray(i) <> Empty Then
            dict(SourceArray(i)) = Empty
        End If
    Next i

    ' Normal: Horizontal (Row)
    If Not Transpose65536 Then getUniqueArray = dict.Keys: GoTo exitProcedure
    ' Transposed: Vertical (Column)
    If dict.Count <= 65536 Then _
      getUniqueArray = Application.Transpose(dict.Keys): GoTo exitProcedure
    ' Transpose only supports up to 65536 items (elements).
    MsgBox "Source Array contains '" & dict.Count & "' unique values." _
      & "Transpose only supports up to 65536 items (elements).", vbCritical, _
      "Custom Error Message: Too Many Elements"

exitProcedure:

End Function