Question

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

这个组合框由一个有6列的薄片组成，每列都是一个组合框。选择每个组合框后，我在此工作表上制作一个过滤器并重新填充下一个组合。

我会举一个例子，试着让它更清晰。

我有一张6列的表格：
大陆|国家|国家|城市|街|建筑物名称

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

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

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

lastRow =表格（“SIP”）。范围（“A65536”）。结束（xlUp）。行
lFiltered = Sheets（“SIP”）。Range（“A2：F”＆amp; lastRow）.SpecialCells（xlCellTypeVisible）.Cells

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

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

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

非常感谢。

- 编辑 -

以下是代码的重要部分

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

---编辑---

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

'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

现在我的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

非常感谢！ = d

Answer 1

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

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

假设您总共拥有1000个值。编写代码时，思考您只是在数组中分配1000个元素并将其复制过来。这将是线性时间，O（n）操作。事实上，你正在分配1 + 2 + 3 + 4 ... + 1000个元素=分配和复制500,000，这将是多项式时间，一个O（n ^ 2）操作。

解决方案是：

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

即，首先：

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

一旦你有了这个尺寸：

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）使用Collection，而不是使用需要调整大小且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

Answer 2

我认为你需要设置：

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

VBA选择过滤的单元格

2 个答案: