Получить результаты фильтра Excel в массив VBA

Question

У меня есть подпрограмма VBA, которая фильтрует записи, которые имеют текст «SV-PCS7» в столбце 4. Как я могу получить эти результаты в массив?

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 

Answer 1

Если вы хотите избежать сложного цикла решения Jeeped (превосходного), вы можете использовать временный листок, чтобы сначала скопировать видимые строки.

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 

Answer 2

Похоже, что лучший способ сделать это цикл по каждой строке, проверяя, если строка скрыта (cell.EntireRow.Hidden = False), и добавление данных для этой строки в массив, если он не скрыт. Подобный пример: Easiest way to loop through a filtered list with VBA?

Answer 3

После применения Range.AutoFilter Method и определения того, что есть видимые ячейки, вы должны работать через Range.Areas property в Range.SpecialCells method с xlCellTypeVisible. Каждая из областей будет иметь одну или несколько строк для обработки.

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 array (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 array 
    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 

Опция Preserve может быть использован с ReDim statement, но только последний диапазон может быть redimensioned. Я построил массив в неправильной ориентации, а затем использовал TRANSPOSE function, чтобы перевернуть ориентацию. Примечание. Существуют ограничения на количество элементов массива, которые могут быть успешно перевернуты.