从数组中删除重复项 - vba

Question

I have a code, that grabs data from a column of a file, and puts it into an array.

now, I want to go through this array and delete duplicates but I can't make it go through... any ideas?

this is the code, and the array is at the end:

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

Remove the duplicates during the string construction by testing for prior existence with 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

You should also remove the last trailing comma before splitting.

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

Finally, if you had added the values into a Scripting.Dictionary object (which comes with its own unique primary key index), you would have a unique set of keys in an array already built for you.

Answer 2

This worked for me:

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

Hope it helps

Answer 3

Easiest way would be to duplicate the sheet you take your input from and use built-in function to get rid of the duplicates, take a look at this :

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 ;)

Or even faster (as you won't have empty cells in the range after the 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

Usually I use a dictionary object to check for duplicates, or use it itself. A dictionary is an object that references unique keys to values. Since the keys have to be unique it is quite usable for collecting unique values. Maybe it is not the most memory efficient way and probaby a little abues of the object, but it works quite fine. You have to dim an object and set it to a dictionary, collect the data, after checking it doesn't already exist and then loop through the dictionary to collect the values.

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, ",")

That's the quick and dirty solution. Since the keys are unique you could probably use them by themselves, without putting them together in the string first. By the way: First of all, you shoudl specify which cells you use. Sometimes you start the macro form another worksheet and then it will use the cells there, if no parent worksheet is given for the cells object. Second, it is important to specify you want to use the cells value for the dictionary, since a dictionary object can contain anything. So if you don't use cells(x,y).value the object will contain the cell itself.

edit: Corrected typo in the routine.

Answer 5

Unique Column To Array

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