Comment copier une plage filtrée dans un tableau? (Excel VBA)

Question

J'utilise cette formule pour copier des enregistrements uniques de la colonne A dans la colonne B.

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

lieu de le copier dans la colonne B comment mettez-vous les résultats filtrés dans un tableau dans Excel VBA?

Answer 1

Vous voulez Read this et il vous diriger dans la bonne direction

Il dit:

1. Utilisez la méthode AdvancedFilter pour créer la plage filtrée dans une zone inutilisée d'une feuille de calcul
2. Affectez la propriété Value de cette plage à un Variant pour créer un tableau à deux dimensions
3. Utilisez la méthode ClearContents de t gamme de chapeau pour se débarrasser

Answer 2

Ce qui suit prend des informations de la colonne A et donne une liste. Il suppose que vous avez un "Sheet3" qui est disponible pour la saisie de données (vous pouvez changer cela).

Sub test() 

    Dim targetRng As Range 
    Dim i As Integer 

    Set targetRng = Sheets(3).Range("a1") 
    Range("A1", Range("A999").End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=targetRng, Unique:=True 

    Dim numbElements As Integer 
    numbElements = targetRng.End(xlDown).Row 
    Dim arr() As String 

    ReDim arr(1 To numbElements) As String 

    For i = 1 To numbElements 
     arr(i) = targetRng.Offset(i - 1, 0).Value 
    Next i 

End Sub 

Answer 3

Sub tester() 

    Dim arr 
    arr = UniquesFromRange(ActiveSheet.Range("A1:A5")) 
    If UBound(arr) = -1 Then 
     Debug.Print "no values found" 
    Else 
     Debug.Print "got array of unique values" 
    End If 

End Sub 


Function UniquesFromRange(rng As Range) 
    Dim d As Object, c As Range, tmp 
    Set d = CreateObject("scripting.dictionary") 
    For Each c In rng.Cells 
     tmp = Trim(c.Value) 
     If Len(tmp) > 0 Then 
      If Not d.Exists(tmp) Then d.Add tmp, 1 
     End If 
    Next c 
    UniquesFromRange = d.keys 
End Function 

Answer 4

Il a été exactement un an que cette question a été posée, mais je couru aujourd'hui dans le même problème et est ici ma solution pour elle:

Function copyFilteredData() As Variant 
    Dim selectedData() As Variant 
    Dim aCnt As Long 
    Dim rCnt As Long 

    Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select 
    On Error GoTo MakeArray: 
    For aCnt = 1 To Selection.Areas.Count 
     For rCnt = 1 To Selection.Areas(aCnt).Rows.Count 
      ReDim Preserve SelectedData(UBound(selectedData) + 1) 
      selectedData(UBound(selectedData)) = Selection.Areas(aCnt).Rows(rCnt) 
     Next 
    Next 

    copyFilteredData = selectedData 
    Exit Function 

MakeArray: 
    ReDim selectedData(1) 
    Resume Next 

End Function 

Cela laissera l'élément 0 du tableau vide mais UBound (SelectedData) renvoie le nombre de lignes dans la sélection

Answer 5

Juste au cas où quelqu'un regarderait encore ceci ... J'ai créé cette fonction pour travailler sur un 1-D gamme, mais il va aussi écrire un plage de dimension supérieure à un tableau 1D; il ne devrait pas être trop difficile à modifier pour écrire une gamme de dimensions multiples dans un tableau de "même forme". Vous devez avoir une référence à scrrun.dll pour créer l'objet dictionnaire. Mise à l'échelle peut être un problème car un « pour chaque » boucle est utilisée, mais si vous utilisez ce EXCEL est rien probable que vous êtes sur le point inquiet:

Function RangeToArrUnique(rng As Range) 
    Dim d As Object, cl As Range 
    Set d = CreateObject("Scripting.Dictionary") 
    For Each cl In rng 
     d(cl.Value) = 1 
    Next cl 
    RangeToArrUnique = d.keys 
End Function 

Je l'ai testé ce de cette façon:

Dim dat as worksheet 
set dat = sheets("Data") 
roomArr = Array("OR01","OR02","OR03") 
dat.UsedRange.AutoFilter field:=2, criteria1:=roomArr, operator:=xlFilterValues 
fltArr = RangeToArrUnique(dat.UsedRange.SpecialCells(CellTypeVisible)) 

J'espère que ça aide quelqu'un!