web-dev-qa-db-fra.com

Un moyen plus rapide d'obtenir toutes les valeurs uniques d'une colonne dans VBA?

Y a-t-il un moyen plus rapide de faire cela?

Set data = ws.UsedRange

Set unique = CreateObject("Scripting.Dictionary")

On Error Resume Next
For x = 1 To data.Rows.Count
    unique.Add data(x, some_column_number).Value, 1
Next x
On Error GoTo 0

À ce point unique.keys obtient ce dont j'ai besoin, mais la boucle elle-même semble être très lente pour les fichiers contenant des dizaines de milliers d'enregistrements (alors que cela ne poserait aucun problème dans un langage comme Python ou C++ en particulier).

excelvba
21
AJJ

Charger les valeurs dans un tableau serait beaucoup plus rapide:

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

Vous devez également envisager une liaison anticipée pour Scripting.Dictionary:

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

Notez que l’utilisation d’un dictionnaire est bien plus rapide que Range.AdvancedFilter sur les grands ensembles de données.

En bonus, voici une procédure similaire à Range.RemoveDuplicates pour supprimer les doublons d'un tableau 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
11
Florent B.

tilisez la fonction AdvancedFilter d'Excel pour le faire.

Utiliser Excels C++ intégré est le moyen le plus rapide avec des jeux de données plus petits. L'utilisation du dictionnaire est plus rapide pour les jeux de données plus volumineux. Par exemple:

Copiez les valeurs dans la colonne A et insérez les valeurs uniques dans la colonne B:

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

Cela fonctionne aussi avec plusieurs colonnes:

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

PowerShell est un outil très puissant et efficace. Ceci triche un peu, mais bombarder PowerShell via VBA ouvre de nombreuses options

Le gros du code ci-dessous consiste simplement à enregistrer la feuille actuelle en tant que fichier csv. La sortie est un autre fichier csv avec uniquement les valeurs uniques

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
5
brettdj

Essaye ça

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

il devrait être assez rapide et sans l'inconvénient NeepNeepNeep a parlé de

1
user3598756