Excel VBA: Filter and copy from top 5 rows/cells - excel

Question

I have a data table which is sorted on descending order in column F. I then need to copy the top 5 rows, but only data from Column A, B, D, and F (not the headers). See pictures.
Sub top5()
Sheets("Sheet1").Select
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
ActiveSheet.Range("$A$4:$T$321").AutoFilter Field:=3, Criteria1:="Dave"
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add _
Key:=Range("F4:F321"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' This copy-paste part does what its supposed to, but only for the specific
' cells. Its not generalised and I will have to repeat this operation
' several times for different people
Sheets("Sheet1").Select
Range("A3:B15").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("D3:D15").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("C3").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("F3:F15").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("D3").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
I thought about trying to adapt this snippet of code below using visible cells function, but I'm stuck and I can't find anything on the net which fits.
' This selects all rows (plus 1, probably due to offset), I only want parts of from the top 5.
Sheets("Sheet1").Select
ActiveSheet.Range("$A$4:$B$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
ActiveSheet.Range("$D$4:$D$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("C3").Select
ActiveSheet.Paste
I hope my example makes sense and I really appreciate your help!
Note: The heading names are only the same in the two tables to show that the data is the same. The headers are NOT supposed to be copied. In addition, there is an extra column/white space in the second table. A solution should include this.

Answer 1

Firstly a few helpful points:
You should refer to worksheets by there Code Name to avoid renaming issues.
If you want to work with VBA then my advice is to avoid merged cells like the plague. They cause havoc with code. If possible use format cells - alignment - horizontal - centre accross selection
I also advise avoiding loops wherever possible and take advantage of excels built in functions instead as a good practice exercise.
Here is my solution. Keep it simple. If you need further help let me now.
Sub HTH()
Dim rCopy As Range
With Sheet1.AutoFilter.Range
'// Set to somewhere blank and unused on your worksheet
Set rCopy = Sheet1.Range("A" & Rows.Count - (.Rows.Count))
.SpecialCells(xlCellTypeVisible).Copy rCopy
End With
With rCopy.Offset(1).Resize(5) '// Offset to avoid the header
.Resize(, 2).Copy Sheet2.Range("A5")
.Offset(, 3).Resize(, 1).Copy Sheet2.Range("D5")
.Offset(, 5).Resize(, 1).Copy Sheet2.Range("F5")
.CurrentRegion.Delete xlUp '// Delete the tempory area
End With
Set rCopy = Nothing
End Sub

Answer 2

A quick way to do this is to use Union and Intersect to only copy the cells that you want. If you are pasting values (or the data is not a formula to start), this works well. Thinking about it, it builds a range of columns to keep using Union and then Intersect that with the first 5 rows of data with 2 header rows. The result is a copy of only the data you want with formatting intact.
Edit only process visible rows, grabbing the header, and then the first 5 below the header rows
Sub CopyTopFiveFromSpecificColumns()
'set up the headers first to keep
Dim rng_top5 As Range
Set rng_top5 = Range("3:4").EntireRow
Dim int_index As Integer
'start below the headers and keep all the visible cells
For Each cell In Intersect( _
ActiveSheet.UsedRange.Offset(5), _
Range("A:A").SpecialCells(xlCellTypeVisible))
'add row to keepers
Set rng_top5 = Union(rng_top5, cell.EntireRow)
'track how many items have been stored
int_index = int_index + 1
If int_index >= 5 Then
Exit For
End If
Next cell
'copy only certain columns of the keepers
Intersect(rng_top5, _
Union(Range("A:A"), _
Range("B:B"), _
Range("D:D"), _
Range("F:F"))).Copy
'using Sheet2 here, you can set to wherever, works if data is not formulas
Range("Sheet2!A1").PasteSpecial xlPasteAll
'if the data contains formulas, use this route
'Range("Sheet2!A1").PasteSpecial xlPasteValues
'Range("Sheet2!A1").PasteSpecial xlPasteFormats
End Sub
Here is the result I get from some dummy data set up in the same ranges as the picture above.
Sheet1 with copied range visible
Sheet2 with pasted data

Answer 3

The first part of your question, selecting the top5 visible cells, is relatively easy, the copying and pasting is where the trouble are. You see, you cannot paste a range, even if it is not uniform, into non uniform range. So you'll need to write your own Paste function.
Part 1 - Getting the Top5 rows
I used a similar technique to #Byron's. Notice that this is merely a function returning a Range object and accepting a String, which represents your non-uniform range (you can change the parameter type to Range if you wish).
Function GetTop5Range(SourceAddress As String) As Range
Dim rngSource As Range
Dim rngVisible As Range
Dim rngIntersect As Range
Dim rngTop5 As Range
Dim i As Integer
Dim cell As Range
Set rngSource = Range(SourceAddress)
Set rngVisible = rngSource.SpecialCells(xlCellTypeVisible).Cells
Set rngIntersect = Intersect(rngVisible, rngVisible.Cells(1, 1).EntireColumn)
i = 1
For Each cell In rngIntersect
If i = 1 Then
Set rngTop5 = cell.EntireRow
i = i + 1
ElseIf i > 1 And i < 6 Then
Set rngTop5 = Union(rngTop5, cell.EntireRow)
i = i + 1
Else
Exit For
End If
Next cell
Set GetTop5Range = Intersect(rngTop5, rngVisible)
End Function
Part 2 - Creating your own pasting function
Because Excel always pastes your copied range as uniform, you need to do it yourself. This method essentially breaks down your source region to columns and pastes them individually. The method accepts parameter SourceRange of type Range , which is meant to by your Top5 range, and a TopLeftCornerRange of type Range, which represents the target cell of your pasting.
Sub PasteRange(SourceRange As Range, TopLeftCornerRange As Range)
Dim rngColumnRange As Range
Dim cell As Range
Set rngColumnRange = Intersect(SourceRange, SourceRange.Cells(1, 1).EntireRow)
For Each cell In rngColumnRange
Intersect(SourceRange, cell.EntireColumn).Copy
TopLeftCornerRange.Offset(0, cell.Column - 1).PasteSpecial xlPasteValuesAndNumberFormats
Next cell
Application.CutCopyMode = False
End Sub
Part 3 - Running the procedure
Sub Main()
PasteRange GetTop5Range("A2:B33,D2:D33"), Range("A35")
End Sub
That's it.
In my project, I had source data in Columns A, B and D like you did and the results are pasted to range beginning at A35.
Result:
Hope this helps!

Answer 4

While it may simply be easier to loop through the first five visible rows, I used application.evaluate to process a worksheet-style formula that returned the row number of the fifth visible record.
Sub sort_filter_copy()
Dim lr As Long, lc As Long, flr As Long, rws As Long, v As Long
Dim sCRIT As String
Dim vCOLs As Variant, vVALs As Variant
Dim bCopyFormulas As Boolean, bSort2Keys As Boolean
bCopyFormulas = True
bSort2Keys = False
sCRIT = "dave"
vCOLs = Array(1, 2, 4, 6)
With Sheet1
lr = .Cells(Rows.Count, 1).End(xlUp).Row
lc = .Cells(4, Columns.Count).End(xlToLeft).Column
With .Cells(5, 1).Resize(lr - 4, lc)
'sort on column F as if there was no header
If bSort2Keys Then
.Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _
Key2:=.Columns(7), Order2:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlNo
Else
.Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlNo
End If
With .Offset(-1, 0).Resize(.Rows.Count + 1, .Columns.Count)
.AutoFilter
.AutoFilter field:=3, Criteria1:=sCRIT
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
rws = Application.Min(5, Application.Subtotal(103, .Columns(3)))
If CBool(rws) Then
flr = Application.Evaluate("=small(index(rows(5:" & lr & ") + ('" & Sheet1.Name & "'!C5:C" & lr & "<>" & Chr(34) & sCRIT & Chr(34) & ")*1e99, , ), " & rws & ")")
For v = LBound(vCOLs) To UBound(vCOLs)
If .Columns(vCOLs(v)).Cells(1).HasFormula And bCopyFormulas Then
Sheet2.Cells(3, vCOLs(v)).Resize(5, 1).FormulaR1C1 = _
.Columns(vCOLs(v)).Cells(1).FormulaR1C1
Else
.Columns(vCOLs(v)).Resize(flr - 4, 1).Copy _
Destination:=Sheet2.Cells(3, vCOLs(v))
End If
Next v
End If
End With
.AutoFilter
End With
'uncomment the next line if you want to return to a standard ascending sort on column A
'.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
End With
End With
End Sub
All options are set just below the variable declarations. Your sample images seemed to indicate that you used a two key sort so I coded for that optionally. If you want to bring in any formulas as formulas, that option is there. The filter criteria and the columns to copy are assigned to their respective vars as well.
        
My sample workbook is available on my public DropBox at:
      Sort_Filter_Copy_from_Top_5.xlsb

Answer 5

Try this:
Sub GetTopFiveRows()
Dim table As Range, cl As Range, cnt As Integer
Set table = Worksheets("Sheet1").Range("A2:A10").SpecialCells(xlCellTypeVisible)
cnt = 1
With Worksheets("Sheet2")
For Each cl In table
If cnt <= 5 Then
.Range("A" & cnt) = cl
.Range("B" & cnt) = cl.Offset(0, 1)
.Range("D" & cnt) = cl.Offset(0, 3)
.Range("F" & cnt) = cl.Offset(0, 5)
cnt = cnt + 1
Else
Exit Sub
End If
Next cl
End With
End Sub
First a reference is set to only visible rows in the entire table (you'll need to update the range reference)
Then we loop over the visible range, copy to sheet 2, and stop when 5 records (i.e. the top five) have been copied

Answer 6

First Unmerge the cells then use this code, very similar to some of the other suggestions.
Sub Button1_Click()
Dim sh As Worksheet
Dim Rws As Long, Rng As Range, fRng As Range, c As Range, fRw As Long
Set sh = Sheets("Sheet2")
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Cells(4, 1), Cells(Rws, "T")) 'unmerge all the headers
Rng.AutoFilter Field:=3, Criteria1:="Dave"
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add _
Key:=Range("F4:F321"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set fRng = Range(Cells(5, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible)
x = 0
For Each c In fRng.Cells
If x = 5 Then Exit Sub
fRw = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
sh.Range(sh.Cells(fRw, 1), sh.Cells(fRw, 2)).Value = Range(Cells(c.Row, 1), Cells(c.Row, 2)).Value
sh.Cells(fRw, 4).Value = Cells(c.Row, 4).Value
sh.Cells(fRw, 6).Value = Cells(c.Row, 6).Value
x = x + 1
Next c
End Sub