VBA選擇過濾的單元格

Question

我在表單中有一個用戶窗體。 在這種形式中，我有6個組合框。

該組合框從6列的工作表填充，每列都轉到組合框。 選中每個組合框後，我在該工作表上製作過濾器並重新填充下一個組合框。

我給你一個例子，試圖讓它更清楚。

我有一張6列的表格：
Continent |國家|狀態|城市|街道|建築物名稱

此表有所有這些itens的所有可能的組合。 例如： 對於街道中的每棟建築物，我都有一排所有相同的5個第一項和最後一個更改。

當用戶打開表單時，我用表格的第一列填充第一個組合框（我做了一個例程以獲取獨特的項目）。 當用戶更改第一個組合框時，我將過濾器應用於第一列中的工作表，然後使用過濾後的工作表填充第二個組合框。

我的問題是如何獲得過濾範圍。 我這樣做：。

LASTROW =表（ 「SIP」）範圍（ 「A65536」）結束（xlUp）.Row
lFiltered =表（ 「SIP」）範圍（「A2：F 「& 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

我想你需要一個設置在那裏：

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 

Answer 2

明顯的性能水槽這裏是您正在使用使用ReDim保留在緊密循環。

爲了解釋這個問題，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保留一次。

也就是說，第一：

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）而不是使用數組，需要調整，並且其使用ReDim保留需要一個特定的大小，使用一個集合。在內部，集合被實現爲類似於鏈接列表的東西，這樣添加項目的時間是固定的（所以O（1）用於每個操作，因此O（n）用於插入全部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