удалить дубликаты из массива - 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

Самый простой способ будет дублировать лист взять входные данные из и использовать встроенную функцию, чтобы избавиться от дубликатов, посмотрите на это:

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 2

Удалите дубликаты во время строковой конструкции, проверив их для предшествующего существования с помощью 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 3

Обычно я использую объект словаря для проверки дубликатов или его использования. Словарь - это объект, который ссылается на уникальные ключи к значениям. Поскольку ключи должны быть уникальными, он вполне может использоваться для сбора уникальных значений. Может быть, это не самый эффективный способ памяти, а probaby немного уклоняется от объекта, но он работает очень хорошо. Вы должны затушить объект и установить его в словарь, собрать данные, после проверки его еще не существует, а затем прокрутите словарь, чтобы получить значения.

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

Это быстрое и грязное решение. Поскольку ключи уникальны, вы, вероятно, можете использовать их сами, не помещая их вместе в строку сначала. Кстати: Прежде всего, вы указываете, какие ячейки вы используете. Иногда вы начинаете макрос формировать другой рабочий лист, а затем он будет использовать ячейки там, если родительский лист не указан для объекта cell. Во-вторых, важно указать, что вы хотите использовать значение ячеек для словаря, поскольку объект словаря может содержать что угодно. Поэтому, если вы не используете ячейки (x, y) .value, объект будет содержать сама ячейка.

Редактировать: Исправлена ​​опечатка в рутине.

Answer 4

Это работает для меня:

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 

Надеется, что это помогает