Ottieni i risultati dei filtri di Excel in un arrays VBA

Ho una sottoprogramma VBA che filtra i record che hanno il text "SV-PCS7" nella colonna 4. Come posso get questi risultati in un arrays?

Sub FilterTo1Criteria() Dim xlbook As Excel.Workbook Dim xlsheet As Excel.Worksheet Dim ro As Integer Set xlbook = GetObject("C:\07509\04-LB-06 MX-sv.xlsx") Set xlsheet = xlbook.Sheets("04-LB-06 MX") With xlsheet .AutoFilterMode = False .Range("blockn").AutoFilter Field:=1, Criteria1:="SV-PCS7" End With End Sub 

Se si desidera evitare il ciclo complesso della soluzione (ottima) di Jeeped, è ansible utilizzare un foglio di temp per copiare prima le righe visibili.

 Sub test() Dim src As Range, m As Variant, sh As Worksheet Set src = Sheet1.Range("c3").CurrentRegion.SpecialCells(xlCellTypeVisible) Set sh = Worksheets.Add src.Copy sh.Range("a1") m = sh.Range("a1").CurrentRegion Application.DisplayAlerts = False sh.Delete Application.DisplayAlerts = True Debug.Print UBound(m) End Sub 

Dopo aver applicato il metodo Range.AutoFilter e determinando che ci sono celle visibili, è necessario lavorare attraverso la properties; Range.Areas del metodo Range.SpecialCells con xlCellTypeVisible. Ciascuna delle aree avrà una o più righe da elaborare.

 Sub FilterTo1Criteria() Dim a As Long, r As Long, c As Long, vals As Variant Dim xlSheet As Worksheet 'Set xlbook = GetObject("C:\07509\04-LB-06 MX-sv.xlsx") Set xlSheet = Worksheets("04-LB-06 MX") With xlSheet If .AutoFilterMode Then .AutoFilterMode = False 'With .Range("blockn") With .Cells(1, 1).CurrentRegion .AutoFilter Field:=1, Criteria1:="SV-PCS7" 'step off the header row With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) 'check if there are visible cells If CBool(Application.Subtotal(103, .Cells)) Then 'dimension the arrays (backwards) ReDim vals(1 To .Columns.Count, 1 To 1) 'loop through the areas For a = 1 To .SpecialCells(xlCellTypeVisible).Areas.Count With .SpecialCells(xlCellTypeVisible).Areas(a) 'loop through the rows in each area For r = 1 To .Rows.Count 'put the call values in backwards because we cannot redim the 'row' For c = LBound(vals, 1) To UBound(vals, 1) vals(c, UBound(vals, 2)) = .Cells(r, c).Value Next c 'make room for the next ReDim Preserve vals(1 To UBound(vals, 1), 1 To UBound(vals, 2) + 1) Next r End With Next a End If End With End With If .AutoFilterMode Then .AutoFilterMode = False End With 'trim off the last empty 'row' ReDim Preserve vals(1 To UBound(vals, 1), 1 To UBound(vals, 2) - 1) 'reorient the arrays vals = Application.Transpose(vals) 'show the extents Debug.Print LBound(vals, 1) & ":" & UBound(vals, 1) Debug.Print LBound(vals, 2) & ":" & UBound(vals, 2) 'show the values For r = LBound(vals, 1) To UBound(vals, 1) For c = LBound(vals, 2) To UBound(vals, 2) Debug.Print vals(r, c) Next c Next r End Sub 

L'opzione Preserve può essere utilizzata con l' istruzione ReDim ma solo l'ultima gamma può essere ridimensionata. Ho costruito l'arrays nell'orientamento errato e ho poi usato la function TRANSPOSE per far ruotare l'orientamento. Nota: ci sono limiti alla quantità di elementi di arrays che possono essere riusciti con successo.

Sembra che il modo migliore per farlo è looping attraverso each row, verificando se la row è nascosta ( cell.EntireRow.Hidden = False ) e aggiungendo i dati per quella row nell'arrays se non è nascosta. Esempio simile: il modo più semplice per passare attraverso un elenco filtrato con VBA?