如何将筛选后的区域复制到数组中？（Excel VBA）

Question

我使用这个公式将列A中的唯一记录复制到列B中。

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

在Excel VBA中，如何将筛选后的结果放入数组而不是复制到B列中？

- MrPatterns

---

没有内置的方法可以实现这个。您可以将数据复制到临时位置（例如隐藏工作表），然后再将其转移到数组中。 - Tim Williams

啊，好的。有没有一种方法可以只使用代码而不是隐藏工作表上的单元格来实现相同的结果？也就是说，找到范围A1：A100中所有唯一的记录（避免重复值）并将它们放入一个数组中。 - MrPatterns

Answer 1

距离这个问题被问出已经一年了，但我今天遇到了同样的问题，这是我的解决方案：

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 

这将使数组的第一个元素为空，但 UBound(SelectedData) 返回所选行数。

- Johan G

---

Redim是一项非常耗费资源的操作。我不会像那样在循环中使用它，除非预期的迭代次数非常低。 - Mor Sagmon

@MorSagmon 你能解释一下redim为什么会很耗费资源吗？ - Johan G

除此之外，您还应该避免使用 Select，并声明一些范围来代替 Selection。除此之外，方法不错。 - Wolfie

Answer 2

以防有人再看这个… 我创建了这个函数来处理一维范围，但它也将更高维度的范围写入一维数组；修改为将多维范围写入“相同形状”的数组也不应该太难。您需要引用scrrun.dll来创建字典对象。缩放可能是一个问题，因为使用了“for each”循环，但如果您正在使用EXCEL，则这可能不是您担心的事情：

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

我用以下方法进行了测试：

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

希望这能帮助到某些人！

- mmurrietta

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

- Tim Williams

Answer 4

这里有另一种方法来完成它。如果没有结果，它就什么也不做。

Public Sub filteredRangeToArray(rg As Range, arr As Variant)

Dim i As Long
Dim j As Long
Dim row As Range
'If 0 results in Filter just exit
If Not rg.SpecialCells(xlCellTypeVisible).Count > 0 Then Exit Sub
i = 1
Erase arr
ReDim arr(1 To rg.Columns.Count, 1 To _
   rg.Columns(1).SpecialCells(xlCellTypeVisible).Count)
For Each row In rg.Rows
 If Not row.Hidden Then
  For j = LBound(arr, 1) To UBound(arr, 1)
  arr(j, i) = row.Cells(j)
  Next j
  i = i + 1
 End If
Next row
arr = WorksheetFunction.Transpose(arr)
End Sub

- Charlio

Answer 5

您会想要阅读此文，它将指引您朝正确的方向前进。

它说：

1. 使用AdvancedFilter方法在工作表的某个未使用区域创建筛选范围
2. 将该范围的Value属性分配给Variant以创建二维数组
3. 使用该范围的ClearContents方法来清除它

- Sorceri

---

请发布此链接的步骤，或至少是一张截图，而不仅仅是一个裸链接。 - brettdj

Sorceri，此链接底部的代码正是我需要的确切答案。它将过滤器复制到一个数组中。 - MrPatterns

从性能角度考虑，将整个数据集放入数组中，然后从中构建所需的数组是否比将其移出到 Excel 电子表格中，再将其读回到数组中，最后清除电子表格中的数据更好？ - MorkPork

Answer 6

使用复制粘贴技巧将筛选范围存储到数组中的简单方法是创建一个工作表并将其隐藏或非常隐藏。假设它的代码名称为，此函数将给您一个2D数组，除非您只有一列并且筛选行仅为一行，在这种情况下它将是一个简单的变体变量而不是数组。

Function GetArrayFromFilteredRange(rng As Range) As Variant
    Dim arr As Variant
    
    sht_calc.Cells.Clear
    rng.Copy sht_calc.Range("A1")
    arr = sht_calc.UsedRange.Value
    
    GetArrayFromFilteredRange = arr
End Function

例如，如果您想在代码名称为sht1的工作表中获取名为Table1的表中已筛选行的数组，只需执行以下操作：

dim rng as range
arr = GetArrayFromFilteredRange(sht1.ListObjects("Table1").DataBodyRange.SpecialCells(xlCellTypeVisible))

arr=GetArrayFromFilteredRange(rng)

- Ibo

Answer 7

以下内容取自A列的信息并提供一个列表。它假定您有一个名为“Sheet3”的可用于数据输入的工作表（您可能希望更改此选项）。

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

- enderland