Блог

Я использую автофильтр для уменьшения диапазона данных на основе определенных критериев. Как только фильтр будет применен, у меня может быть что угодно от 100 до 1000 строк. Я знаю, что до запуска фильтра я захочу скопировать определенное количество строк из этого отфильтрованного списка — часто это небольшое число, например, 3, 4 или 5. Я сохраняю это число в переменной под названием SELECTIONS. Чего я изо всех сил пытаюсь добиться, так это скопировать это количество строк из отфильтрованных данных. Я пробовал различные подходы, но ни один из них, похоже, не позволяет мне копировать нужные строки.

Вот мой код ниже:

 'Define how many selections are required Dim selections As Integer selections = Sheets("MO Systems").Range("Q2").Value  Dim LastRow, SelectRow As Long  'Defines sheet and row where we will paste data SelectRow = Sheets("Selections").Range("A165536").End(xlUp).Row   1  'Remove any autofilter than had previously been applied Sheets("Overs Assessment").Select If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then ActiveSheet.ShowAllData End If  'Apply Filters 'Filter 1 Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=3, Criteria1:="gt;1.0" 'Filter 2 Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=50, Criteria1:="gt;=3.9", Operator:=xlAnd, Criteria2:="lt;=7" 'Filter 3 Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=37, Criteria1:="gt;1.79", Operator:=xlAnd 'Filter 4 Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=58, Criteria1:="gt;=4.54", Operator:=xlAnd, Criteria2:="lt;=11.99" 'Date Filter Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=1, Criteria1:=Sheets("MO Systems").Range("F2").Value  'If there is only one selection, I can copy the lastrow and this is simple If selections = 1 Then LastRow = Sheets("Overs Assessment").Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row Sheets("Overs Assessment").Range("A" amp; LastRow amp; ":E" amp; LastRow).Copy Sheets("Selections").Range("A" amp; SelectRow).PasteSpecial xlValues Else 'If selections gt; 1, this is where I cannot seem to find a solution to copy the relevant cells. End If  

Выполните итерацию в обратном направлении по областям и строкам несмежного отфильтрованного диапазона и заполните массив номерами строк.

 Option Explicit  Sub CopyEnd()   'Define how many selections are required  Dim selections As Integer  Dim wsSrc As Worksheet, wsDest As Worksheet  Dim rngFilter As Range, rngCopy  Dim LastRow As Long, destRow As Long    selections = Sheets("MO Systems").Range("Q2").Value    'Defines sheet and row where we will paste data  Set wsDest = Sheets("Selections")  With wsDest  destRow = .Cells(.Rows.Count, 1).End(xlUp).Row   1  End With    Set wsSrc = Sheets("Overs Assessment")  With wsSrc  ' set filter range  LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row  Set rngFilter = .Range("A1:V" amp; LastRow)    'Remove any autofilter than had previously been applied  If (.AutoFilterMode And .FilterMode) Or .FilterMode Then  .ShowAllData  End If   'Apply Filters  With rngFilter  'Filter 1,3,3,4,Date  .AutoFilter  .AutoFilter Field:=3, Criteria1:="gt;1.0"  .AutoFilter Field:=50, Criteria1:="gt;=3.9", Operator:=xlAnd, Criteria2:="lt;=7"  .AutoFilter Field:=37, Criteria1:="gt;1.79"  .AutoFilter Field:=58, Criteria1:="gt;=4.54", Operator:=xlAnd, Criteria2:="lt;=11.99"  .AutoFilter Field:=1, Criteria1:=Sheets("MO Systems").Range("F2").Value  ' rng to copy  Set rngCopy = .SpecialCells(xlCellTypeVisible)  MsgBox "Filter Range is " amp; rngCopy.Address    '.AutoFilter ' remove filters  End With    ' fill array with row numbers of last n rows  Dim i As Long, k As Long, n As Long, a, r, ar  n = selections  ReDim ar(1 To n)  For a = rngCopy.Areas.Count To 1 Step -1  If i = n Then Exit For  For r = rngCopy.Areas(a).Rows.Count To 1 Step -1  If a gt; 1 Or r gt; 1 Then ' exclude header  i = i   1  ar(i) = rngCopy.Areas(a).Rows(r).Row  End If  If i = n Then Exit For  Next  Next    ' copy rows  MsgBox i amp; " rows " amp; Join(ar, ":")  For k = i To 1 Step -1  wsDest.Cells(destRow, 1).Resize(, 5).Value2 = .Cells(ar(k), 1).Resize(, 5).Value2  destRow = destRow   1  Next    End With  MsgBox "Done"  End Sub  

Один из способов… (отрегулируйте диапазоны и листы в соответствии с требованиями)

 Sub test() Dim selections As Long Dim cntRows As Long, i As Long, iRow As Long, iArea As Long Dim rngFilter As Range Dim rngSource As Range Dim rngDest As Range Dim rArea As Range   selections = 10    Set rngFilter = Worksheets("Sheet1").Range("A2:B11") ' ("A2:FW50881")    Set rngSource = rngFilter.SpecialCells(xlCellTypeVisible) ' probably a multi area range   For Each rArea In rngSource.Areas  cntRows = cntRows   rArea.Rows.Count ' count filtered rows  Next    If cntRows lt; selections Then selections = cntRows '    Set rngDest = Worksheets("Sheet2").Range("A1:B" amp; selections)  i = selections    For iArea = rngSource.Areas.Count To 1 Step -1  Set rArea = rngSource.Areas(iArea)  For iRow = rArea.Rows.Count To 1 Step -1  rngDest.Rows(i).Value = rArea.Rows(iRow).Value ' if need row formats copy/paste  i = i - 1  If i = 0 Then Exit For  Next  If i = 0 Then Exit For  Next  End Sub  

Если смежные строки, скорее всего, находятся в отфильтрованном диапазоне, быстрее копируйте соответствующие области, однако немного больше занимайтесь домашним хозяйством.

Еще один подход: добавьте все видимые ячейки в ColA в коллекцию, а затем используйте эту коллекцию для выбора строк для копирования.

 Sub Tester()    Dim wsOvers As Worksheet, c As Range  Dim selections As Long 'lt;lt;lt;lt; always prefer Long to Integer  Dim LastRow As Long, PasteCell As Range, rngVis As Range, n As Long  Dim col As New Collection, i As Long    selections = Sheets("MO Systems").Range("Q2").Value    Set PasteCell = Sheets("Selections").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)    Set wsOvers = Sheets("Overs Assessment")    With wsOvers  If (.AutoFilterMode And .FilterMode) Or .FilterMode Then .ShowAllData  With .Range("$A$1:$FW$50881")  .AutoFilter Field:=3, Criteria1:="gt;1.0"  .AutoFilter Field:=50, Criteria1:="gt;=3.9", Operator:=xlAnd, Criteria2:="lt;=7"  .AutoFilter Field:=37, Criteria1:="gt;1.79", Operator:=xlAnd  .AutoFilter Field:=58, Criteria1:="gt;=4.54", Operator:=xlAnd, Criteria2:="lt;=11.99"  .AutoFilter Field:=1, Criteria1:=Sheets("MO Systems").Range("F2").Value  Set rngVis = .SpecialCells(xlCellTypeVisible)  End With  End With    n = 0  For Each c In rngVis.Columns(1).Cells 'loop over all visible cells in ColA  n = n   1 ' and add them to a collection  If n gt; 1 Then col.Add c '...skipping the header  Next c    'now copy the selected last # of rows  For n = 1 To selections  i = col.Count - (n - 1) 'collection index  If i lt; 1 Then Exit For 'not enough items in the collection  PasteCell.Resize(1, 5).Value = col(i).Resize(1, 5).Value  Set PasteCell = PasteCell.Offset(1) 'next row down  Next n   End Sub