如何将过滤后的范围复制到数组中？(Excel VBA)
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/11995761/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How do I copy a filtered range into an array? (Excel VBA)
提问by phan
I use this formula to copy unique records from Column A into Column B.
我使用此公式将唯一记录从 A 列复制到 B 列。
Range("A1", Range("A100").End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
Instead of copying it into Column B how do you put the filtered results into an array in Excel VBA?
您如何将过滤后的结果放入 Excel VBA 中的数组中，而不是将其复制到 B 列中？
采纳答案by Sorceri
You will want to Read thisand it will point you in the right direction
你会想要阅读这篇文章，它会为你指明正确的方向
It says:
它说：
- Use the AdvancedFilter method to create the filtered range in some unused area of a worksheet
- Assign the Value property of that range to a Variant to create a two-dimensional array
- Use the ClearContents method of that range to get rid of it
- 使用 AdvancedFilter 方法在工作表的一些未使用区域创建过滤范围
- 将该范围的 Value 属性分配给 Variant 以创建二维数组
- 使用该范围的 ClearContents 方法来摆脱它
回答by Johan Godfried
It has been exactly a year since this question was asked but I ran into the same problem today and here is my solution for it:
问这个问题已经整整一年了，但我今天遇到了同样的问题，这是我的解决方案：
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
This will leave element 0 of the array empty but UBound(SelectedData) returns the number of rows in the selection
这将使数组的元素 0 为空，但 UBound(SelectedData) 返回选择中的行数
回答by mmurrietta
Just in case anyone ever looks at this again... I created this function to work on a 1-D range but it will also write a higher dimension range to a 1-D array; it shouldn't be too hard to modify to write a multiple dimension range to a "same shape" array. You need to have a reference to scrrun.dll to create the dictionary object. Scaling may be a problem since a "for each" loop is used but if you are using EXCEL this is likely nothing you are worried about:
以防万一有人再看一遍……我创建了这个函数来处理一维范围，但它也会将更高维度的范围写入一维数组；修改将多维范围写入“相同形状”数组应该不会太难。您需要引用 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
I've tested this in this way:
我以这种方式对此进行了测试：
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))
Hope this helps someone out there!
希望这可以帮助那里的人！
回答by Tim Williams
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
回答by enderland
The following takes information from column A and gives a list. It assumes you have a "Sheet3" which is available for data input (you may wish to change this).
下面从 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
