如何将过滤的范围复制到数组中？ （Excel VBA）
我使用此公式将A列中的唯一logging复制到B列中。
Range("A1", Range("A100").End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True 而不是将其复制到列B如何将过滤的结果放入Excel VBA中的数组？
你会想要阅读这个 ，它会指出你在正确的方向
它说：
- 使用AdvancedFilter方法在工作表的某个未使用区域中创build已过滤的范围
- 将该范围的Value属性指定给Variant以创build一个二维数组
- 使用该范围的ClearContents方法来摆脱它
问了这个问题已经有一整年的时间了，但是我今天遇到了同样的问题，这里是我的解决scheme：
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
这将使数组的元素0为空，但是UBound（SelectedData）返回select中的行数
以防万一有人再次看到这个…我创造了这个函数在一维范围内工作，但它也将一个更高的维度范围写入一维数组; 修改多维度范围以写入“相同形状”的数组并不难。 您需要具有对scrrun.dll的引用来创build字典对象。 缩放可能是一个问题，因为使用了“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
我以这种方式testing了这个：
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))
希望这可以帮助那里的人！
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
以下从列A中获取信息并给出一个列表。 它假定你有一个“Sheet3”可用于数据input（你可能希望改变这个）。
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