从一个数组中删除重复的内容 - 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函数.

    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