How can I select the exact number of items after applying the filter? - excel

Question

I need to select a group of items after applying the filter and it works until a certain number of items.
I use 'Areas' to select the set of items because sometimes it needs to select the first one, two, three... until ten items. The variable which determines how long the selection will be is called rangeA, rangeB and rangeC for SELECTION A, SELECTION B and SELECTION C, respectively. Also, the number of columns for each selection is always the same. After the selection is done it's copied and pasted for each selection. It works this way:
the filter is applied
the selection (A, B and C one per time) is copied
the selection is pasted on the "Worksheet 2"
for selection A, B and C.
One observation is that I will always have items to select because "DATA" is too big, it has over 13 thousand items.
Sub SELECT()
Dim area As Range
Dim CellCount As Integer
Dim firstCell As Range 'firstCell and lastCell determines how big the selection will be.
Dim lastCell As Range
Dim rangeA, rangeB, rangeC As Variant
rangeA = Range("v20").Value 'this is the cell where the number of rows I want (one to ten)
rangeB = Range("v21").Value
rangeC = Range("v22").Value
'############# SELECTION A #################'
'##########################################
Application.Goto ActiveWorkbook.Sheets("DATA").Cells(11, 3)
ActiveSheet.Range("$A$11:$P$65").AutoFilter Field:=10, Criteria1:= _
"FILTER X"
ActiveSheet.Range("$A$11:$P$74").AutoFilter Field:=7, Criteria1:="A"
With ActiveSheet.Range("B11").Offset(1, 0).Resize(Rows.Count - ActiveSheet.Range("B11").Row, 1)
'first cell will be the the first cell of Areas(1)
Set firstCell = .SpecialCells(xlCellTypeVisible).Areas(1).Cells(1, 7)
'Get last cell by looping through areas until their total cell count reaches 4.
For Each area In .SpecialCells(xlCellTypeVisible).Areas
'first area may already contain more than N cells, in which case we just get its Nth cell and exit. "N" is rangeA, rangeB or rangeC
'If this is not the case, we add up rows.Count of each area until we get more than N, and when that happens,
'we get the cell of last area which is needed to get to N.
If CellCount + area.Rows.Count >= Range("v20").Value Then
Set lastCell = area.Cells(Range("v20").Value - CellCount, 0)
Exit For
End If
CellCount = CellCount + area.Rows.Count
Next
End With
'finally, from the firstCell and lastCell we can get the range of first N visible cells.
ActiveSheet.Range(firstCell, lastCell).Select
Selection.Copy
Application.Goto ActiveWorkbook.Sheets("Worksheet 2").Cells(8, 2)
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
''############# SELECTION B #################'
'##############################################
Application.Goto ActiveWorkbook.Sheets("DATA").Cells(11, 3)
ActiveSheet.Range("$A$11:$P$65").AutoFilter Field:=10, Criteria1:= _
"FILTER X"
ActiveSheet.Range("$A$11:$P$74").AutoFilter Field:=7, Criteria1:="B"
With ActiveSheet.Range("B11").Offset(1, 0).Resize(Rows.Count - ActiveSheet.Range("B11").Row, 1)
Set firstCell = .SpecialCells(xlCellTypeVisible).Areas(1).Cells(1, 7)
For Each area In .SpecialCells(xlCellTypeVisible).Areas
If CellCount + area.Rows.Count >= Range("V21").Value Then
Set lastCell = area.Cells(Range("V21").Value - CellCount, 0)
Exit For
End If
CellCount = CellCount + area.Rows.Count
Next
'End If
End With
ActiveSheet.Range(firstCell, lastCell).Select
Selection.Copy
Application.Goto ActiveWorkbook.Sheets("Worksheet 2").Cells(Range("v20").Value + 8, 2)
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("BASE DE DADOS").Activate
ActiveSheet.ShowAllData
'############# SELECTION C #######################'
'################################################
Application.Goto ActiveWorkbook.Sheets("DATA").Cells(11, 3)
ActiveSheet.Range("$A$11:$P$65").AutoFilter Field:=10, Criteria1:= _
"FILTER X"
ActiveSheet.Range("$A$11:$P$74").AutoFilter Field:=7, Criteria1:="C"
With ActiveSheet.Range("B11").Offset(1, 0).Resize(Rows.Count - ActiveSheet.Range("B11").Row, 1)
Set firstCell = .SpecialCells(xlCellTypeVisible).Areas(1).Cells(1, 7)
For Each area In .SpecialCells(xlCellTypeVisible).Areas
If CellCount + area.Rows.Count >= Range("V22").Value Then
Set lastCell = area.Cells(Range("V22").Value - CellCount, 0)
Exit For
End If
CellCount = CellCount + area.Rows.Count
Next
End With
ActiveSheet.Range(firstCell, lastCell).Select
Selection.Copy
Application.Goto ActiveWorkbook.Sheets("Worksheet 2").Cells(Range("v21").Value + Range("v20").Value + 8, 2)
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("BASE DE DADOS").Activate
ActiveSheet.ShowAllData
End Sub
Another observation is that when I run one selection alone it works perfectly fine (it can be one, two, three,... ten items). But when I run two selections (any combinations) it works until certain number of items, for rangeA and rangeB it works for 1 and 3 but it doesn't work for 3 and 3. In this last case it selects 3 items of A (correct) but only 1 item of B.
Also, it works for the three selections when the rangeA, rangeB and rangeC are respectively 3, 1, 1.
Any ideas?

Answer 1

Make the selection a function so you can re-use same code for each selection.
Option Explicit
Sub selectABC()
Dim wsData As Worksheet, ws2 As Worksheet, rngTarget As Range
Dim countA As Long, countB As Long, countC As Long, n As Long
With ThisWorkbook
Set wsData = .Sheets("DATA")
Set ws2 = .Sheets("worksheet 2")
End With
With wsData
'these are the cells where the number of rows I want
countA = 1 '.Range("v20").Value
countB = 4 ' .Range("v21").Value
countC = 4 ' .Range("v22").Value
End With
'selection A
Set rngTarget = ws2.Range("B8")
n = myselect(wsData, rngTarget, "FILTER X", "A", countA)
'selection B
Set rngTarget = rngTarget.Offset(n)
n = myselect(wsData, rngTarget, "FILTER X", "B", countB)
'selection C
Set rngTarget = rngTarget.Offset(n)
Call myselect(wsData, rngTarget, "FILTER X", "C", countC)
End Sub
Function myselect(wsData, rngTarget, f1, f2, maxrows) As Long
Dim rng As Range, a As Range, rngVisible As Range, rngCopy As Range
Dim lastrow As Long, n As Long, m As Long
With wsData
lastrow = .UsedRange.Row + .UsedRange.Rows.Count - 1
With .Range("A11:P" & lastrow)
.AutoFilter Field:=10, Criteria1:=f1 ' col J
.AutoFilter Field:=7, Criteria1:=f2 ' col G
Set rngVisible = .SpecialCells(xlCellTypeVisible)
If rngVisible Is Nothing Then
MsgBox " Error no data", vbCritical
Exit Function
End If
.AutoFilter
End With
'Debug.Print rngVisible.Address, f1, f2, lastrow
n = 0
m = 0
For Each a In rngVisible.Areas
For Each rng In a.Rows
' skip first headers
If n > 0 Then
If rngCopy Is Nothing Then
Set rngCopy = rng
Else
Set rngCopy = Union(rngCopy, rng)
End If
m = m + 1 ' row count
End If
n = n + 1
If n > maxrows Then Exit For
Next
If n > maxrows Then Exit For
Next
If rngCopy Is Nothing Then
' no data
Else
'Debug.Print rngCopy.Address
rngCopy.Copy
rngTarget.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' remove selection shading
rngTarget.Parent.Activate
rngTarget.Select
End If
End With
myselect = m
MsgBox m & " rows copied for J=" & f1 & " G=" & f2
End Function