I have a Workbook in which there is a sheet named "tracker" that shows certain actionables that need to be closed by team member by target date. I can do it on excel using filters. But I tried ti build a VBA code to automate the process which is
Search for Status of action in column 28. If it is "Open" then Check if "target date" in column 43 is exited as of today. I put today date in column 46. If Target date is exceeded then I want that row to be copy pasted in another worksheet "Open Items". The code should move to next item in 2 situations, either the status is "closed" of Target date is yet to arrive.
Following is code I wrote. The code is executed properly but I get only the last row as output in Open items sheet. The code do not seem to check for status or dates properly
Sub OpenItems()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets("Open Items").Select
Cells.Select
'Range("E16").Activate
Selection.Delete Shift:=xlUp
Sheets("Observation Tracker").Select
Range("A2").Select
Sheets("Observation Tracker").Activate
Lastrow = Cells(Rows.Count, "AQ").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets("Observation Tracker").Cells(Rows.Count,"AU").End(xlUp).Row + 1
For i = 2 To Lastrow
If Cells(i, 28).Value = "Open" Then
If Cells(i, 43).Value < Cells(i, 46).Value Then
Rows(i).Copy Sheets("Open items").Rows(Lastrow)
i = i + 1
End If
End If
Next
Sheets("Observation Tracker").Select
Rows("1:1").Select
Selection.Copy
Sheets("Open Items").Select
Range("AI1").Select
Selection.End(xlToLeft).Select
ActiveSheet.Paste
Range("A1").Select
MsgBox "Open Items Extracted"
Application.ScreenUpdating = True
End Sub
I want all open items with dates passed by to populate in the Open Item worksheet
This line here Rows(i).Copy Sheets("Open items").Rows(Lastrow) will always paste to the same row because you never increment lastrow. So as your code loops through the sheet the output is constantly being overwritten until the last match is made which is the only one you will see.
Rows(i).Copy Sheets("Open items").Rows(Lastrow)
lastrow = lastrow + 1
I don't think you need i = i + 1 either because your for loop is already incrementing i so you are skipping a line every time it gets there.
EDIT:
Here is what I came up with.
Sub OpenItems()
Dim i As Long
Dim lastrow As Long
Dim lastcol As Long
Dim pasteiter As Long
Application.ScreenUpdating = False
With Sheets("Open Items")
'This will clear the contents of Open Items
lastrow = .Cells(Rows.Count, 43).End(xlUp).Row
lastcol = .Cells.Find(What:="*", after:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
.Range(.Cells(2, 1), .Cells(lastrow, lastcol)).ClearContents
End With
pasteiter = 2 'Make sure we don't overwrite anything
With Sheets("Observation Tracker")
lastrow = .Cells(Rows.Count, "AQ").End(xlUp).Row
For i = 2 To lastrow
'Combined the two IF statements since we weren't using the outer else.
If (.Cells(i, 28).Value = "Open") And (.Cells(i, 43).Value <= .Cells(i, 46).Value) Then
.Rows(i).Copy Sheets("Open Items").Rows(pasteiter)
pasteiter = pasteiter + 1
End If
Next
.Rows(1).Copy Sheets("Open Items").Rows(1) 'Grab the headers
End With
Application.ScreenUpdating = True
MsgBox "Open Items Extracted"
'I'm not sure what your last bits of code did I removed them.
End Sub
If open items sheet is blank just put something in the first row the first time you run this otherwise you will get a with/object error. Should only occur the first time though.
I removed all your selections and activates, they aren't necessary, slow things down, and obfuscate your code. I also removed lastrowa as it didn't appear to be used.
My code is supposed to select all of the items in A-H from the top of the sheet to the bottom most row containing text in the J column. However, now all it does is select the top row. This code has worked fine elsewhere for other purposes, but when I run it here it only selects the top row.
Here is the code and what it currently does. The commented out bit does the same when it is ran in the place of the other finalrow =statement.
Option Explicit
Sub FindRow()
Dim reportsheet As Worksheet
Dim finalrow As Integer
Set reportsheet = Sheet29
Sheet29.Activate
'finalrow = Cells(Rows.Count, 10).End(xlUp).Row
finalrow = Range("J1048576").End(xlUp).Row
If Not IsEmpty(Sheet29.Range("B2").Value) Then
Range(Cells(1, 1), Cells(finalrow, 8)).Select
End If
End Sub
This is the excerpt of code with a row counter that works.
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
''loop through the rows to find the matching records
For i = 1 To finalrow
If Cells(i, 1) = item_code Then ''if the name in H1 matches the search name then
Range(Cells(i, 1), Cells(i, 9)).Copy ''copy columns 1 to 9 (A to I)
reportsheet.Select ''go to the report sheet
Range("A200").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False ''find the first blank and paste info there
datasheet.Select ''go back to the data sheet and continue searching
End If
Next i
You can try this:
Option Explicit
Sub FindRow()
' always use Longs over Integers
Dim finalrow As Long: finalrow = 1
' you might not need this line tbh
Sheet29.Activate
With Sheet29
' custom find last row
Do While True
finalrow = finalrow + 1
If Len(CStr(.Range("J" & finalrow).Value)) = 0 Then Exit Do
Loop
' Len() is sometimes better then IsEmpty()
If Len(CStr(.Range("B2").Value)) > 0 Then
.Range(.Cells(1, 1), .Cells((finalrow - 1), 8)).Select
End If
End With
End Sub
Sequence of events which I am trying to achieve:
1) I have data on Sheet1
2) I filter the data on Sheet1 according to a certain criteria and then copy the data to another Sheet say "Difference". The data has around 8 lines.
3) I then insert 11 lines between the data on sheet "Difference" after every 2 lines.
4) Next I insert 4 columns before the first column
5) I then insert the column header for the first 4 inserted column and row headers till the UsedRange.
6) After that I am doing certain less intensive calculations on the data such as comparing the values and looking up data from another workbook.
All this is in a macro on click of a button.
While clicking the button what happens is that sometimes I get the rows and columns in a sequence as expected and actually most of the times after the first 4 columns the rows come in a zig zag manner i.e. sometimes they would comes 5 - 6 columns after the first 4 columns and on other runs of a macro the rows would come after 50 lines or so.
I investigated my code but couldn't find any reason why this is happening. Also this happens intermittently. As I mentioned sometimes the result comes fine and most of the times the result (rows and columns) come in a zig zag manner.
Why is macro doing this? I am really having a hard time thinking about it? I have no answer. It seems so illogical.
I could post my code but it's too big. Please let me know which portion of the code should I post.
Please do suggest. Having a really hard time.
I am posting my code snippet below:
Private Sub CommandButton1_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim wb As Workbook
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim ws As Worksheet
Dim i As Long
Set wb = GetObject(ActiveWorkbook.Path & "\ReconUtility_Enhanced.xlsm")
Set sh1 = wb.Sheets("Sheet1")
Set sh2 = wb.Sheets("Sheet2")
MsgBox sh2.UsedRange.Rows.count
For i = 1 To sh2.UsedRange.Rows.count
sh1.Activate
ActiveSheet.UsedRange.Select
Selection.AutoFilter
sh1.Range("E1").AutoFilter Field:=5, Criteria1:=sh2.Cells(i, 1).Value
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.count))
ws.Name = sh2.Cells(i, 2).Value
End With
Sheets(sh2.Cells(i, 2).Value).Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.UsedRange.Columns.AutoFit
Next i
sh1.Activate
ActiveSheet.UsedRange.Select
Selection.AutoFilter
sh1.Range("E1").AutoFilter Field:=5, Criteria1:="Field Difference"
Selection.Copy
Sheets("Field Difference").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.UsedRange.Columns.AutoFit
MsgBox "Field Difference Copy completd"
' Step 2. Insert 11 lines and Insert 4 columns for analysis
Set sh3 = wb.Sheets("Field Difference")
Dim x As Long
Dim j As Long
Dim i1 As Long
Dim fieldRows As Long
j = 1
fieldRows = sh3.UsedRange.Rows.count
Dim rowsAfterInsertingLines As Long
rowsAfterInsertingLines = fieldRows / 2
Const count = 11
For i1 = 2 To fieldRows
If i1 Mod 2 = 1 Then
For x = 1 To count
sh3.Rows(i1 + j).Insert Shift:=xlDown
j = j + 1
Next
End If
Next i1
MsgBox "Inserted Lines Done"
' Inserting 4 columns before the first column
sh3.Range("A:D").EntireColumn.Insert Shift:=xlToRight
sh3.Range("A1").Value = "Data Source Name"
sh3.Range("B1").Value = "Final Status"
sh3.Range("C1").Value = "UserName"
sh3.Range("D1").Value = "Ownership"
MsgBox "Columns Inserted"
' Now a Loop to insert the values - (CMRS, DTCC-US, Difference, 2 Eye Check, 4 Eye Check)
Dim myModifiedArray() As Variant
myModifiedArray = Array("CMRS", "DTCC-US", "Difference", "Sapient Comments (History)", "Last Sapient Comment / 2 Eye Analysis", "4 Eye Analysis", "4 Eye Comments", "Last Comment made by (Sapient)", "Date of Last Comment (Sapient)", "NWM Comment (History)", "Last NWM Commnent", "Last Comment made by (NWM)", "Date of Last Comment (NWM)")
Dim rCount As Long
rCount = 2
Dim iCount As Long
Dim jCount As Long
For iCount = 1 To rowsAfterInsertingLines
For jCount = LBound(myModifiedArray) To UBound(myModifiedArray)
sh3.Cells(rCount, 1).Value = myModifiedArray(jCount)
rCount = rCount + 1
Next jCount
Next iCount
MsgBox "Row headers inserted"
End Sub
I use two workbooks (obviously based on the question:)), from the first one (as you will see in the code below) gets sorted by the data in column "B". The data in this column is just a number based on the month (11=November, December=12, etc.). For this question (and it will provide the answer for my other monthly workbooks), need to copy all the rows of data (columns A:AE) in column B to another workbook (which is already open), and paste the data into the empty row at the bottom. I have the sort part working fine. I am trying to add in the copy & paste function into the code, but can't get it to work. HELP!
Here is the code I have tried (but can't figure out how to get focus to the target workbook):
Sub Extract_Sort_1512_December()
' This line renames the worksheet to "Extract"
Application.ScreenUpdating = False
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Range("B" & LR).Value <> "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = “12” Then
Range(Cells(i, 1), Cells(i, 31)).Select
Selection.Copy
ActiveWorkbook(“Master File - Swivel - December 2015.xlsm”).Select
Worksheets(“Master”).Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub
I have found this code below, but do not know how to insert it properly into my code above. The thing that makes me weary is that the workbooks are already open. The target workbook is located on our SharePoint site and I do not know how (or if) you can use VBA code to open it to your desktop.
Here is the other code:
Sub Demo()
Dim wbSource As Workbook
Dim wbTarget As Workbook
' First open both workbooks :
Set wbSource = Workbooks.Open(" ") ' <<< path to source workbook
Set wbTarget = ActiveWorkbook ' Workbooks.Open(" ") ' <<< path to destination workbook
'Now, transfer values from wbSource to wbTarget:
wbTarget.Sheets("Sheet1").Range("B2").Value = wbSource.Sheets("Sheet3").Range("H4")
wbTarget.Sheets("Sheet1").Range("B3").Value = wbSource.Sheets("Sheet3").Range("J10")
'Close source:
wbSource.Close
End Sub
I have modified your code slightly, but kept most of it as is.
I think the problem was related to the way in which you were trying to activate the workbook where the data was to be pasted. Normally the Activate command is used with workbooks, as opposed to Select. However, I bypassed the whole activation of the new workbook, because it would require you to then "re-activate" the original workbook before copying the next line. Otherwise you would be copying from the active workbook, which would now be the one to be pasted into. Please see the code - it should be fairly straightforward.
Sub Extract_Sort_1512_December()
Application.ScreenUpdating = False
' This line renames the worksheet to "Extract"
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Not Range("B" & LR).Value = "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = "12" Then
' As opposed to selecting the cells, I just copy them directly
Range(Cells(i, 1), Cells(i, 31)).Copy
' As opposed to "Activating" the workbook, and selecting the sheet, I just paste the cells directly
With Workbooks("Master File - Swivel - December 2015.xlsm").Sheets("Master")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(erow, 1).PasteSpecial xlPasteAll
End With
Application.CutCopyMode = False
End If
Next i
Application.ScreenUpdating = True
End Sub
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.
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
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
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!
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
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
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