VBA 选择过滤的单元格

VBA Select Filtered Cells

提问by hend

I have a UserForm in a sheet. In this form I have 6 combobox.

我在工作表中有一个用户表单。在这种形式中，我有 6 个组合框。

This combobox are populated from a sheet with 6 columns, each column goes to a combobox. After each combobox is selected, I make a filter at this sheet and repopulate the next one.

这个组合框是从一张有 6 列的工作表中填充的，每一列都转到一个组合框。选择每个组合框后，我在此工作表上创建一个过滤器并重新填充下一个。

I'll give you an example to try to make it more clear.

我会给你一个例子，试图让它更清楚。

I have a sheet with 6 columns:
Continent | Country | State | City | Street | Name of the building

我有一个 6 列的工作表：
大陆 | 国家 | 状态 | 城市 | 街 | 建筑物名称

This sheet have ALL the possible combinations for all this itens. For example: For each building in a street I have a row with all the same 5 first items and the last one changes.

此表包含所有这些项目的所有可能组合。例如：对于街道上的每个建筑物，我有一排所有相同的 5 个第一项，最后一个更改。

When the user opens the form I populate the first combobox with the first column of the sheet (I do a routine to get unique items). When the user changes the first combobox, I apply a filter to the sheet in the first column and then I populate the second combobox with the filtered sheet.

当用户打开表单时，我用工作表的第一列填充第一个组合框（我执行一个例程来获取唯一项目）。当用户更改第一个组合框时，我将过滤器应用于第一列中的工作表，然后使用过滤后的工作表填充第二个组合框。

My problem is how to get the filtered range. I'm doing this:

我的问题是如何获得过滤范围。我这样做：

lastRow = Sheets("SIP").Range("A65536").End(xlUp).Row
lFiltered = Sheets("SIP").Range("A2:F" & lastRow).SpecialCells(xlCellTypeVisible).Cells

lastRow = Sheets("SIP").Range("A65536").End(xlUp).Row
lFiltered = Sheets("SIP").Range("A2:F" & lastRow).SpecialCells(xlCellTypeVisible).Cells

It works fine. But when I apply a filter and it hides, for exemple, only the row 10, the lFiltered variable will return only until row 9. It breaks on the first hidden row and does not return any row after that.

它工作正常。但是，当我应用过滤器并隐藏（例如，仅第 10 行）时，lFiltered 变量将仅返回到第 9 行。它在第一个隐藏行处中断，之后不返回任何行。

The solution I came up with is to do a foreach with every row and check if its visible or not, but the code gets really, really slow. It takes up to 10 seconds to populate each combobox.

我想出的解决方案是对每一行做一个 foreach 并检查它是否可见，但代码变得非常非常慢。填充每个组合框最多需要 10 秒钟。

Anyone have any idea how can I work around this issue?

任何人都知道我该如何解决这个问题？

Thank you very much.

非常感谢。

-- edit --

- 编辑 -

Here is the important part of the code

这是代码的重要部分

Dim listaDados As New Collection
Dim comboList() As String
Dim currentValue As String
Dim splitValue() As String
Dim i As Integer
Dim l As Variant
Dim lFiltered As Variant
Dim lastRow As Integer

'Here I found the last row from the table
lastRow = Sheets("SIP").Range("A65536").End(xlUp).Row
'I do this because when the filter filters everything, lastRow = 1 so I got an erros on lFiltered range, it becames Range("A2:F1")
If lastRow < 2 Then
    lastRow = 2
End If
'Here I get an array with all the visible rows from the table -> lFiltered(row, column) = value
lFiltered = Sheets("SIP").Range("A2:F" & lastRow).SpecialCells(xlCellTypeVisible).Cells
'I have duplicated entries, so I insert everything in a Collection, so it only allows me to have one of each value
on error resume next
For i = 1 To UBound(lFiltered)
    currentValue = Trim(lFiltered(i, column))
    If currentValue <> 0 Then
        If currentValue <> "" Then
            'Cammel case the string
            currentValue = UCase(Left(currentValue, 1)) & LCase(Mid(currentValue, 2))
            'Upper case the content in between "( )"
            splitValue = Split(currentValue, "(", 2)
            currentValue = splitValue(0) & "(" & UCase(splitValue(1))
            'Insert new item to the collection
            listaDados.Add Item:=currentValue, Key:=currentValue
        End If
    End If
Next i
i = 1
'Here I copy the collection to an array
ReDim Preserve comboList(0)
comboList(0) = ""
For Each l In listaDados
    ReDim Preserve comboList(i)
    comboList(i) = l
    i = i + 1
Next l

'Here I assign that array to the combobox
formPerda.Controls("cGrupo" & column).List = comboList

--- edit ---

- - 编辑 - -

Here is how I managed the code to work the way I want.

这是我如何管理代码以我想要的方式工作。

'Get the last row the filter shows
lastRow = Sheets("SIP").Range("A65536").End(xlUp).Row
'To avoid to get the header of the table
If lastRow < 2 Then
    lastRow = 2
End If
'Get the multiple range showed by the autofilter
Set lFilteredAux = Sheets("SIP").Range("A2:F" & lastRow).Cells.SpecialCells(xlCellTypeVisible)

'Check if there is more than 1 no contiguous areas
If Sheets("SIP").Range(lFilteredAux.Address).Areas.Count > 1 Then
    'If Yes, do a loop through the areas
    For i = 1 To Sheets("SIP").Range(lFilteredAux.Address).Areas.Count
        'And add it to the lFiltered array
        ReDim Preserve lFiltered(i - 1)
        lFiltered(i - 1) = Sheets("SIP").Range(lFilteredAux.Address).Areas(i)
    Next i
Else
    'If there is only one area, it goes the old way
    ReDim lFiltered(0)
    lFiltered(0) = Sheets("SIP").Range(lFilteredAux.Address)
End If

Now I have the lFiltered array a little different than the way I was using, but I adapted my foreach to work like this:

现在我的 lFiltered 数组与我使用的方式略有不同，但我调整了我的 foreach 使其工作如下：

For i = 0 To UBound(lFiltered)
        For j = 1 To UBound(lFiltered(i))
            currentValue = Trim(lFiltered(i)(j, columnNumber))
        next j
next i

Thanks a lot! =D

非常感谢！=D

回答by josh waxman

The obvious performance sink here is that you are using ReDim Preserve in a tight loop.

这里明显的性能下降是您在紧密循环中使用 ReDim Preserve。

To explain, that little ReDim Preserve statement does a lot of work. If you have an array of size 4 and you ReDim it to size 5, it allocates 5 spaces and also copies over the 4 values from the previous array. If you then ReDim it to size 6, it allocates 6 spaces and also copies over the 5 values from the previous array.

解释一下，这个小小的 ReDim Preserve 语句做了很多工作。如果您有一个大小为 4 的数组并将其重新调整为大小为 5，它会分配 5 个空间并复制前一个数组中的 4 个值。如果然后将其重新调整为 6 大小，它会分配 6 个空间并复制前一个数组中的 5 个值。

Say you have 1000 values total. When writing the code, you thoughtthat you were merely allocating 1000 elements in the array and copying them over. This would be in linear time, an O(n) operation. In truth, you were allocating 1 + 2 + 3 + 4 ... + 1000 elements = allocating and copying 500,000, which would be in polynomial time, an O(n^2) operation.

假设您总共有 1000 个值。在编写代码时，您认为您只是在数组中分配 1000 个元素并复制它们。这将是线性时间，O(n) 操作。实际上，您正在分配 1 + 2 + 3 + 4 ... + 1000 个元素 = 分配和复制 500,000，这将是多项式时间，O(n^2) 运算。

The solution is either:

解决方案是：

1) Outside the loop, figure out the size of your array and then only ReDim Preserve once.

1) 在循环外，计算出数组的大小，然后仅 ReDim Preserve 一次。

That is, first:

也就是说，首先：

Dim totalSize as Long, i as Long 
For i = 1 To Sheets("SIP").Range(lFilteredAux.Address).Areas.Count
    totalSize += 1
Next I

And once you have the size:

一旦你有了尺寸：

ReDim Preserve lFiltered(totalSize - 1)
For i = 1 To Sheets("SIP").Range(lFilteredAux.Address).Areas.Count
     lFiltered(i - 1) = Sheets("SIP").Range(lFilteredAux.Address).Areas(i)
Next i

2) Instead of using an array, which needs resizing, and whose ReDim Preserve requires a specific size, use a Collection. Internally, the Collection is implemented as something like a linked list, such that adding an item happens in constant time (so O(1) for each operation and so O(n) total for inserting all n items).

2) 不使用需要调整大小且其 ReDim Preserve 需要特定大小的数组，而是使用集合。在内部，Collection 被实现为类似于链表的东西，这样添加一个项目会在恒定时间内发生（因此每个操作的 O(1) 和插入所有 n 个项目的 O(n) 总计）。

Dim c as New Collection
ReDim Preserve lFiltered(totalSize - 1)
For i = 1 To Sheets("SIP").Range(lFilteredAux.Address).Areas.Count
     c.Add Sheets("SIP").Range(lFilteredAux.Address).Areas(i)
Next i

回答by Gary's Student

I think you need a Setin there:

我认为你需要一个Set：

Sub dural()
    lastRow = Sheets("SIP").Range("A65536").End(xlUp).Row
    Set lFiltered = Sheets("SIP").Range("A2:F" & lastRow).Cells.SpecialCells(xlCellTypeVisible)
    MsgBox lFiltered.Address
End Sub