Copy and sort data from one sheet to another, based on cell values - excel

I have searched a lot of similar topics and have had some help but I cant find a way to do what I need (probably because of my limited experience with excel and vba), so here it goes:
I have a (Source)sheet 'offers' , which is populated daily, with the columns below:
columns: b c d e f g
header: offercode issue dt worktype customer sent dt confirmation dt
xxx.xx. 1/1/14 MI john 1/1/14 3/1/14
aaa.aa. 1/1/14 MD bob 2/1/14
bbb.bb 2/1/14 SI peter 2/1/14 3/1/14
what I need is to copy all rows that get a confirmation date (not blank) in another sheet"production orders"(destination)
where I generate production order codes and input other kind of data :
columns: b c d e f g
header: offercode productioncode worktype start end confirmation dt
xxx.xx. 1/1/14 MI 5/1/14 3/1/14
bbb.bb 2/1/14 SI 6/1/14 3/1/14
note that column b and b & c contain formulas (generates offer codes)
my problem is that data is populated daily, and offers(Source Sheet) should be sorted by issue date and once they get confirmed(input confirmation date->non blank) they should be copied in the other sheet but sorted (or polulate the next empty row) by confirmation date eg:
columns: b c d e f g
header: offercode productioncode worktype start end confirmation dt
xxx.xx. XX.XXX. MI 5/1/14 3/1/14
bbb.bb BB.BBB SI 6/1/14 3/1/14
aaa.aa. AA>AAA MD 4/1/14
another issue is how often or when is the second (Destination Sheet) list refreshs with new data, my guess is that a control button click after every data entry instance would work (and make sure that the list is up to date)
thank you in advance,
Angelos

So, this is what is working for me right now, its all based on #simoco's code:
I am checking in it for operational consistency, but the code works fine.
It copies and pastes only the columns of (my) interest where I need it and then sorts a dynamic range.
Sub copycolumnsonly()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim j As Long
Dim i As Long
Dim rng As Range
'set correct name of the sheet with your data'
Set sh1 = ThisWorkbook.Worksheets("ÐÑÏÓÖÏÑÅÓ")
'set correct name of the sheet where you need to paste data'
Set sh2 = ThisWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ")
'determining last row of your data in file ÁÁÁÁÁÁÁÁ.xlsx'
lastrow1 = sh1.Range("C" & sh1.Rows.Count).End(xlUp).Row
'determining last row of your data in file ÂÂÂÂÂÂÂÂ.xls'
lastrow2 = sh2.Range("F" & sh2.Rows.Count).End(xlUp).Row
'clear content in sheet2
sh2.Range("F11:F" & lastrow2).ClearContents
sh2.Range("G11:G" & lastrow2).ClearContents
sh2.Range("N11:N" & lastrow2).ClearContents
'suppose that in sheet2 data starts from row #11
j = 11
For i = 0 To lastrow1
Set rng = sh1.Range("G11").Offset(i, 0)
'check whether value in column D is not empy
If Not (IsNull(rng) Or IsEmpty(rng)) Then
sh1.Range("B" & i + 11).Copy
sh2.Range("F" & j).PasteSpecial xlPasteValues
sh1.Range("g" & i + 11).Copy
sh2.Range("G" & j).PasteSpecial xlPasteValues
sh1.Range("K" & i + 11).Copy
sh2.Range("N" & j).PasteSpecial xlPasteValues
j = j + 1
End If
Next i
Application.CutCopyMode = False
'sorting the new list, recorded macro tweaked to use a dynamic named range
ActiveWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ").Sort.SortFields.Add Key:=Range( _
"G:G"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ").Sort
.SetRange Range("PRODUCTIONORDERS")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

this is what I have come up with as a completly different approach,
I would greatly appreciate it if you could check it for error handling, or invalid input from users etc
(see comments in code)
`
Sub ActiveToLastRow()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim activerow As Long
Dim lastrow2 As Long
Dim rng As Range
Dim confirmation As Range
'set correct name of the sheet with your data
Set sh1 = ThisWorkbook.Worksheets("ÐÑÏÓÖÏÑÅÓ")
'set correct name of the sheet where you need to paste data
Set sh2 = ThisWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ")
'making sure the user selects the correct offercode via inputbox to get its rownumber --> see activerow variable
Set rng = Application.InputBox("dialeje prosfora", "epilogh prosforas", Type:=8)
'getting the information(confirmation date) via input box form the user
Dim TheString As String
Dim TheDate As Date
TheString = Application.InputBox("Enter A Date", "epibebaiwsh anathesis")
If IsDate(TheString) Then
TheDate = DateValue(TheString)
Else
MsgBox "Invalid date"
'need to end sub if user input is invalid
End If
'determining active row of your data in file ÁÁÁÁÁÁÁÁ.xlsx where data input occurs <-- user input via 1st input box
activerow = rng.Row
Set confirmation = sh1.Range("G" & activerow)
confirmation.Value = TheDate
'determining last row of your data in file ÂÂÂÂÂÂÂÂ.xls'
lastrow2 = sh2.Range("F" & sh2.Rows.Count).End(xlUp).Row
'determining what to copy and where
sh1.Range("B" & activerow).Copy
sh2.Range("F" & lastrow2 + 1).PasteSpecial xlPasteValues
sh1.Range("g" & activerow).Copy
sh2.Range("G" & lastrow2 + 1).PasteSpecial xlPasteValues
sh1.Range("K" & activerow).Copy
sh2.Range("N" & lastrow2 + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'activating destination sheet for testing purposes
sh2.Activate
End Sub`

It looks like you simply need to copy over only those rows with a value in the "Confirmation Date" column - if I read the above correctly.
If the sheet with the daily updates is called "First", and the resultant sheet with only the confirmed orders is called "Second", the following should do it...
Sub Macro1()
'
' Macro1 Macro
'
'
lastRow = 10 ' hard coded here; use whatever technique to get real value.
'Copy over the headers to the new sheet
Sheets("First").Select
Rows("1:1").Select
Selection.Copy
Sheets("Second").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("A:F").ColumnWidth = 9
Columns("G:G").ColumnWidth = 12
Sheets("First").Select
' Range("G1").Select
Confirm_Count = 0
For Row = 1 To lastRow
If Len(Range("G1").Offset(Row, 0)) > 1 Then
Rows(Row + 1).Select
Selection.Copy
Sheets("Second").Select
Confirm_Count = Confirm_Count + 1
Range("A1").Offset(Confirm_Count, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("First").Select
End If
Next Row
End Sub

Related

VBA Finding Last Row

I'm trying to copy down a formula down to the last row. I've got code for doing so but it won't work.
My code to find the last row is:
lRow = ws.Range("G" & ws.Rows.Count).End(xlUp).Row
The rest of my code is as follows:
Sub Inventory()
Dim lRow As Integer
lRow = ws.Range("G" & ws.Rows.Count).End(xlUp).Row
'Inventory Macro
Range("G2").Select
' Selects cell G2
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-5]-RC[-2]"
' Calculates Inventory for the first month by subtracting Production Units from Demand
Range("G3").Select
' Selects cell G3
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-5]-RC[-2]+R[-1]C"
' Calculates Inventory for the rest of the months by subtracting Production Units from Demand plus the previous month's Inventory
Range("G3").Select
Selection.AutoFill Destination:=Range("G3:G" & lRow)
Range("G3:G" & lRow).Select
End Sub
Your problem probably stems from the column in which you determine the last row. Here is another version of your code that avoids selecting anything.
Sub Inventory2()
'Inventory Macro
' Calculates Inventory for the rest of the months by subtracting
' Production Units from Demand plus the previous month's Inventory
Dim Ws As Worksheet
Dim lRow As Long
Set Ws = ActiveSheet ' better: name the sheet: Worksheets("Sheet1")
With Ws
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' this can't be column G
.Cells(2, "G").FormulaR1C1 = "=RC[-5]-RC[-2]"
.Range(.Cells(3, "G"), .Cells(lRow, "G")).FormulaR1C1 = "=RC[-5]-RC[-2]+R[-1]C"
End With
End Sub

If cell on sheet2 row1 matches cell on sheet1 then copy row from sheet 2 to sheet 1 and loop for next row

Everyone I am new to code and VBA Excell.
I have a Sub that works, I'm just not sure if it's the right way to do it or if there is a more efficient way as it takes a while to complete when run.
I was just wondering if someone can have a look and maybe give me some pointers.
I will put my code below I hope I'm doing this right.
Thanks
Carly
Sub DataPopulate()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim num As Range
Set wb = ActiveWorkbook
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng1 = Range("F2")
Set num = ws1.Range("F2:F4")
'When you click the Click this to populate data MSRP Pricing button you will get the yes no message box.
If MsgBox("Click yes to continue" & vbCrLf & "Excel may say not responding!!!" _
& vbCrLf & "It just may take a few moments", vbYesNo + vbQuestion) = vbYes Then
'If the yes button is pushed in the message box.
ws1.Activate
Range("e18") = ("MSRP List")
'MSRP List text is copied to cell e18.
Range("h2:h16").Value = Range("g2:g16").Value
'The product group list is copied from colum g to h.
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("f2:f16"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
'The numbers in f2~f16 is sorted in assending order along with the product group name.
End With
Dim Lastrow As Integer
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ws1.Activate
Range("A23:L" & Lastrow).ClearContents ' Select
'Selection.ClearContents
'Count from A23 to column L and the last row with data, then select that and delete.
Range("A22") = ("Group")
Range("b22") = ("Description")
Range("c22") = ("Code")
Range("d22") = ("Barcode")
Range("e22") = ("List Number")
'Copy the data list headings
a = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'Count rows of CSV data on sheet2 and set veriable for "a" this is the number of times to run the loop below.
'MsgBox (a) '<testing count number
For i = 2 To a
Dim d As Range
If ws1.Range("f2").Value = ("1") And ws2.Cells(i, 1).Value = ws1.Range("g2") Then
'Checking if order of product group f2 = 1
'and if there is a match in sheet2 column A row 1 with G2 in product group list
b = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Rows(i).Copy
ws1.Cells(b + 1, 1).PasteSpecial Paste:=xlPasteValues
'Then copy that row to sheet1 in the next empty row
End If
'Loop will do the next rows till "a" times loops are done
Next
'This is the same for below until all product groups are done
For i = 2 To a
If ws1.Range("f3") = 2 And ws2.Cells(i, 1).Value = ws1.Range("g3") Then
b = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Rows(i).Copy
ws1.Cells(b + 1, 1).PasteSpecial Paste:=xlPasteValues
End If
Next
For i = 2 To a
If ws1.Range("f4") = 3 And ws2.Cells(i, 1).Value = ws1.Range("g4") Then
b = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Rows(i).Copy
ws1.Cells(b + 1, 1).PasteSpecial Paste:=xlPasteValues
End If
Next
Dim rng As Range
Set rng = Range("F2:f1000")
'Loop backwards through the rows
'in the range that you want to evaluate.
For i = rng.Rows.Count To 1 Step -1
'If cell i in the range contains an "0", delete the entire row.
If rng.Cells(i).Value = "0" Then rng.Cells(i).EntireRow.Delete
'Deleting rows with at 0
Next
Application.CutCopyMode = False
'ThisWorkbook.ws1.calls(1, 22).Select
ws1.Activate
Range("A24:E24").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
.PatternTintAndShade = 0
End With
Range("A23:E24").Select
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Range("A25:E1000").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A21").Select
'Adding grey scale to the rows to make is eazier to read.
'Else
End If
End Sub
So a basic principal of programming is that your functions/subroutines should only have one job. The first step I would take to improve your code would be breaking your code up into more subroutines using this principal. I won't go too in depth on the advantage of this because there's already loads of resources explaining why to do things this way. This thread has some good explanations, as well as draw backs to breaking your code up too much this way.
What I always do is start with a subroutine called Main() with a job that is simply to call the other functions in the program and pass variables between them as necessary. Make sure all your functions/subroutines have names that describe their purpose and then you will know exactly what your program is doing at each step of the process simply by looking at Main.

Excel formula only bring over row in other worksheet if cell in column A is not blank

I have two worksheets in one Excel workbook, and I only want to take the lines that have data in the cell (from worksheet1 into worksheet2) if Column A has data in it. My formula in worksheet 2 is =IF('Raw Data'!A2<>"", 'Raw Data'!A2,), but I actually don't want it to bring in the row at all if there is no data as shown in Rows 3 and 5. Right now it is bringing the whole row in:
In
you see that it is still bringing the row into worksheet 2 if there is no data. Any ideas how to only bring in the rows with the data?
Sub DataInCell()
Dim rw As Long
rw = 2
' Select initial sheet to copy from
Sheets("Raw Data").Select
' Find the last row of data - xlUp will check from the bottom of the spreadsheet up.
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' For loop through each row
For x = 2 To FinalRow
If Cells(x, 1).Value <> 0 Then
Range("A" & x & ":C" & x).Copy
Sheets("Sheet1").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Continue incrementing through the rows.
Cells(NextRow, 1).Select ' Find the next row.
ActiveSheet.Cells(NextRow, "A").PasteSpecial xlPasteAll ' Paste information.
Sheets("Raw Data").Select 'Reselect sheet to copy from. Probably uneccessary.
End If
Next x
End Sub
After you update the sheet names on the 3rd and 4th line, you will see that the code carries over the entire row. You can modify using Range(Cells, Cells) if you want partial ranges.
Option Explicit
Sub Non_Blanks()
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1") '<-- Master Sheet
Dim ns As Worksheet: Set ns = ThisWorkbook.Sheets("Sheet2") '<-- New Sheet
Dim i As Long, MoveMe As Range, LR As Long
For i = 2 To ms.Range("B" & ms.Rows.Count).End(xlUp).Row
If ms.Range("A" & i) = "*" Then
If Not MoveMe Is Nothing Then
Set MoveMe = Union(MoveMe, ms.Range("A" & i))
Else
Set MoveMe = ms.Range("A" & i)
End If
End If
Next i
If Not MoveMe Is Nothing Then
LR = ns.Range("A" & ns.Rows.Count).End(xlUp).Offset(1).Row
MoveMe.EntireRow.Copy
ns.Range("A" & LR).PasteSpecial xlPasteValuesAndNumberFormats
End If
End Sub

Copying Data to another workbook

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

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

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

Resources