从数组vba中删除重复的内容

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

4 个解决方案

#1

Remove the duplicates during the string construction by testing for prior existence with InStr function.

在字符串构建过程中，通过使用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

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.

最后，如果您已经将值添加到脚本中。Dictionary对象(它有自己唯一的主键索引)，您将在已经为您构建的数组中拥有一组惟一的键。

#2

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

#3

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

希望它能帮助

#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.

通常我使用dictionary对象来检查副本，或者使用它本身。字典是引用值的唯一键的对象。由于键必须是唯一的，所以它对于收集唯一值非常有用。也许这并不是最有效的记忆方式，也不会对物体产生什么影响，但它确实很有用。您必须将对象设置为dim，并将其设置为dictionary，在检查数据不存在之后收集数据，然后循环遍历字典以收集值。

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.

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

edit: Corrected typo in the routine.

编辑:在程序中纠正错误。

#1