Быстрый способ получить все уникальные значения столбца в VBA?

Ответ 1

Загрузка значений в массив будет намного быстрее:

Dim data(), dict As Object, r As Long
Set dict = CreateObject("Scripting.Dictionary")

data = ActiveSheet.UsedRange.Columns(1).Value

For r = 1 To UBound(data)
    dict(data(r, some_column_number)) = Empty
Next

data = WorksheetFunction.Transpose(dict.keys())

Вы должны также рассмотреть раннее связывание для Scripting.Dictionary:

Dim dict As New Scripting.Dictionary  ' requires 'Microsoft Scripting Runtime' '

Обратите внимание, что использование больших словарей намного быстрее, чем Range.AdvancedFilter.

В качестве бонуса, здесь процедура похожа на Range.RemoveDuplicates для удаления дубликатов из 2D-массива:

Public Sub RemoveDuplicates(data, ParamArray columns())
    Dim ret(), indexes(), ids(), r As Long, c As Long
    Dim dict As New Scripting.Dictionary  ' requires 'Microsoft Scripting Runtime' '

    If VarType(data) And vbArray Then Else Err.Raise 5, , "Argument data is not an array"

    ReDim ids(LBound(columns) To UBound(columns))

    For r = LBound(data) To UBound(data)         ' each row '
        For c = LBound(columns) To UBound(columns)   ' each column '
            ids(c) = data(r, columns(c))                ' build id for the row
        Next
        dict(Join$(ids, ChrW(-1))) = r  ' associate the row index to the id '
    Next

    indexes = dict.Items()
    ReDim ret(LBound(data) To LBound(data) + dict.Count - 1, LBound(data, 2) To UBound(data, 2))

    For c = LBound(ret, 2) To UBound(ret, 2)  ' each column '
        For r = LBound(ret) To UBound(ret)      ' each row / unique id '
            ret(r, c) = data(indexes(r - 1), c)   ' copy the value at index '
        Next
    Next

    data = ret
End Sub

Ответ 2

Для этого используйте функцию Excel AdvancedFilter.

Использование Excels со встроенным C++ - самый быстрый способ для небольших наборов данных, использование словаря быстрее для больших наборов данных. Например:

Скопируйте значения в столбце A и вставьте уникальные значения в столбец B:

Range("A1:A6").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True

Он также работает с несколькими столбцами:

Range("A1:B4").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1:E1"), Unique:=True

Будьте осторожны с несколькими столбцами, поскольку они не всегда работают должным образом. В этих случаях я прибегаю к удалению дубликатов, который работает путем выбора столбцов для определения уникальности. Ссылка: MSDN - Найти и удалить дубликаты

Здесь я удаляю повторяющиеся столбцы на основе третьего столбца:

Range("A1:C4").RemoveDuplicates Columns:=3, Header:=xlNo

Здесь я удаляю повторяющиеся столбцы на основе второго и третьего столбцов:

Range("A1:C4").RemoveDuplicates Columns:=Array(2, 3), Header:=xlNo

Ответ 3

PowerShell - очень мощный и эффективный инструмент. Это немного обманывает, но обстрел PowerShell через VBA открывает множество опций

Основная часть приведенного ниже кода - это просто сохранить текущий лист как файл csv. Результатом является другой файл csv с уникальными значениями

Sub AnotherWay()
Dim strPath As String
Dim strPath2 As String

Application.DisplayAlerts = False
strPath = "C:\Temp\test.csv"
strPath2 = "C:\Temp\testout.csv"
ActiveWorkbook.SaveAs strPath, xlCSV
x = Shell("powershell.exe $csv = import-csv -Path """ & strPath & """ -Header A | Select-Object -Unique A | Export-Csv """ & strPath2 & """ -NoTypeInformation", 0)
Application.DisplayAlerts = True

End Sub

Ответ 4

Попробуйте это

Option Explicit

Sub UniqueValues()
Dim ws As Worksheet
Dim uniqueRng As Range
Dim myCol As Long

myCol = 5 '<== set it as per your needs
Set ws = ThisWorkbook.Worksheets("unique") '<== set it as per your needs

Set uniqueRng = GetUniqueValues(ws, myCol)

End Sub


Function GetUniqueValues(ws As Worksheet, col As Long) As Range
Dim firstRow As Long

With ws
    .Columns(col).RemoveDuplicates Columns:=Array(1), header:=xlNo

    firstRow = 1
    If IsEmpty(.Cells(1, col)) Then firstRow = .Cells(1, col).End(xlDown).row

    Set GetUniqueValues = Range(.Cells(firstRow, col), .Cells(.Rows.Count, col).End(xlUp))
End With

End Function

он должен быть довольно быстрым и без недостатка NeepNeepNeep рассказал о