I want to copy only the values (not formulas) of the last sheet of any workbook I run the macro on (I won't know the names of sheets or quantity of sheets) and to delete the B column if it's blank and name this new wirksheet "Games". This is what I have and it's not working =(. Could anyone give me a help?
Sub ArrumarTabela()
ActiveSheet.Copy
Cells.Copy
Application.CutCopyMode = False
ActiveSheet.Name = "Games"
Range("A1").PasteSpecial Paste:=xlPasteValues
Application.ScreenUpdating = False
ActiveSheet.Name = "Games"
Dim cl As Range
For Each cl In Range("$B$2:$B" & Range("$B$65536").End(xlUp).Row)
If cl = "" Then cl.EntireColumn.Delete
Next cl
Range("C1").Select
Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Application.ScreenUpdating = True
End Sub
Will this modification do what you need?
Sub ArrumarTabela()
ActiveSheet.Copy 'this will create a new workbook and a new sheet with current
With ActiveSheet
.Name = "Games" 'change new sheets name
.Cells.Copy 'copy all cells
.Range("A1").PasteSpecial Paste:=xlPasteValues 'paste only values
.ScreenUpdating = False
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row 'last row?
Set cl = .Range("B2:B" & lastrow).Find("", lookat:=xlWhole) 'find a blank cell in a range
If Not cl Is Nothing Then cl.EntireColumn.Delete 'delete column if blank exists
.Range("C1").EntireColumn.Insert 'insert new column belfore column C
.ScreenUpdating = True
End With
End Sub
Related
Excel starts with two sheets.
First a list which includes data for a name, a number, and a product numbers.
The second tab is a template.
I'm trying to:
Copy the template tab, input the name, number, and product into the new tab, and then rename the tab (ActiveSheet.Name = Range("B3").Value).
Loop down to the next row and repeat until there are no more rows.
If a tab already exists with the name, then move onto the next row.
I tried two methods.
The code below I could probably figure out but it would require me to copy and paste the same lines with updated rows about 100 times since it isn't looping.
Also, the macro stops if there's already a tab with the name on it instead of continuing.
I made several attempts to have the macro move on if a tab has already been created from a name on the list but this keeps breaking the macro.
Sub TemplateMultiple()
'
' Tab creation and naming
'
'
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(2)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!RC[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[-1]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(3)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[3]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[0]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(4)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[4]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[1]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(5)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[5]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!R[3]C[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(6)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[6]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!R[4]C[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[3]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
End Sub
The second method involves a loop to make the code much easier to read/follow.
My code is putting the same information into each template instead of going down one row for each spreadsheet.
Sub Template1()
'UpdatebyExtendoffice20161222
Dim x As Integer
Application.ScreenUpdating = False
' Set numrows = number of rows of data.
NumRows = Range("B5", Range("B5").End(xlDown)).Rows.Count
' Select cell a1.
Range("B5").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
' Insert your code here.
Sheets("Template").Select
Sheets("Template").Copy Before:=Sheets(2)
Range("B3:C3").Select
ActiveCell.FormulaR1C1 = "='List'!R[2]C"
Range("B5:C5").Select
ActiveCell.FormulaR1C1 = "='List'!RC[3]"
Range("B6:C6").Select
ActiveCell.FormulaR1C1 = "='List'!R[-1]C[4]"
Range("B7:C7").Select
ActiveSheet.Name = Range("B3").Value
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub
Something like this should work:
Sub Template1()
Dim wb As Workbook, ws As Worksheet, wsList As Worksheet
Dim c As Range, sheetName As String, wsTempl As Worksheet
Set wb = ThisWorkbook
Set wsList = wb.Worksheets("List")
Set wsTempl = wb.Worksheets("Template")
Application.ScreenUpdating = False
For Each c In wsList.Range("B5", wsList.Cells(Rows.Count, "B").End(xlUp)).Cells
sheetName = c.Value
Set ws = GetWorksheet(wb, sheetName) 'see if there's an existing sheet with this name
If ws Is Nothing Then 'if was no matching sheet
wsTempl.Copy before:=wsTempl 'copy template in front of itself
Set ws = wb.Worksheets(wsTempl.Index - 1) 'get a reference to the copy
ws.Name = sheetName
With c.EntireRow
'I never use R1C1 so this might be off...
ws.Range("B3:C3").Formula = "='List'!" & .Columns("B").Address(False, False)
ws.Range("B5:C5").Formula = "='List'!" & .Columns("E").Address(False, False)
ws.Range("B6:C6").Formula = "='List'!" & .Columns("E").Address(False, False)
End With
End If
Next c
Application.ScreenUpdating = True
End Sub
'Return a worksheet named `wsName` from workbook `wb`, or `Nothing` if it doesn't exist
Function GetWorksheet(wb As Workbook, wsName As String) As Worksheet
On Error Resume Next
Set GetWorksheet = wb.Worksheets(wsName)
On Error Goto 0
End Function
Note there's rarely any need to select/activate things before you work with them - that's an artifact of the macro recorder.
See How to avoid using Select in Excel VBA for more on this and some good guidelines to follow.
My goal is to copy and paste rows that meet a certain criteria into a table in another workbook.
My VBA works perfectly except for it pastes in the empty cell below the table. Not in the empty cells below the headers within the table.
PS. I know using select is generally frowned upon, but I needed to use fairly basic syntax so that if the next person needs to modify this and is unfamiliar with VBA they can.
Sub Export()
Sheets("Export Format").Select
Cells(13, "D").Calculate
With Range("A1", Cells(Rows.Count, "L").End(xlUp)) 'reference its column A:G cells from row 1 (header) down to last not empty one in column "A"
.AutoFilter Field:=6, Criteria1:="<>0" ' filter referenced cells on 6th column with everything but "0" content
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy ' copy filtered cells skipping headers
With Workbooks.Open(Filename:="Z:\Tracking\Database.xlsx").Sheets("Sheet1") 'open wanted workbook and reference its wanted sheet
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False 'paste filtered cells in referenced sheet from ist column A first empty cell after last not empty one
.Parent.Close True 'Save and closes referenced workbook
End With
Application.CutCopyMode = False
End If
End With
On Error Resume Next
Sheets("Export Format").ShowAllData 'Clears Filters
On Error GoTo 0
Sheets("Export Format").Select 'Brings back to Main request sheet
End Sub
Try using a property of the table such as InsertRowRange
Sub Export()
Const DBFILE = "Z:\Tracking\Database.xlsx"
Dim wb As Workbook, wbDB As Workbook
Dim ws As Worksheet, tbl As ListObject
Dim rngFilter As Range, x, rng As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Export Format")
x = Application.WorksheetFunction.Subtotal(103, ws.Columns(1))
If x <= 1 Then
ws.Select
Exit Sub
End If
' set filter range
With ws
.Range("D13").Calculate
' column A:L cells from row 1 (header)
' down to last not empty one in column "A"
Set rngFilter = .Range("A1", .Cells(Rows.Count, "L").End(xlUp))
End With
' open wanted workbook and reference its wanted sheet
Set wbDB = Workbooks.Open(DBFILE)
With wbDB.Sheets("Sheet1")
Set tbl = .ListObjects("Table1")
If tbl.InsertRowRange Is Nothing Then
Set rng = tbl.ListRows.Add.Range
Else
Set rng = tbl.InsertRowRange
End If
End With
' filter on 6th column with everything but "0" content
With rngFilter
.AutoFilter Field:=6, Criteria1:="<>0"
' copy filtered cells skipping headers
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
'paste filtered cells in referenced sheet
'from ist column A first empty cell after last not empty one
rng.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
wbDB.Close True 'Save and closes referenced workbook
ws.AutoFilterMode = False
ws.Select 'Brings back to Main request sheet
MsgBox "Ended"
End Sub
I have an excel macro that creates a new sheet called "Compiled", copies over the contents of every sheet in the workbook from A2 onward (so the header isn't copied). This works great, except I often get tons of completely blank rows all over the place.
My objective is to have a macro to find the last row in the Compiled sheet, and delete any fully blank rows.
Here's my current script:
Sub CombineData()
' Delete unneeded sheets
Application.DisplayAlerts = False
Sheets("Instructions").Select
ActiveWindow.SelectedSheets.Delete
Sheets("TM Contacts").Select
ActiveWindow.SelectedSheets.Delete
' Add new sheet called Compiled
Sheets.Add After:=ActiveSheet
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Compiled"
Sheets("Lastname, First Name").Select
Range("Table_1[#Headers]").Select
Selection.Copy
Sheets("Compiled").Select
Range("A1").Select
ActiveSheet.Paste
Range("A2").Select
' Copy all sheet contents onto one
Dim lastRowSource As Long, lastRowDest As Long, i As Long
For i = 1 To Sheets.Count
If Not Sheets(i).Name = "Compiled" Then
lastRowSource = Sheets(i).Cells(Sheets(i).Rows.Count, "A").End(xlUp).Row
lastRowDest = Sheets("Compiled").Cells(Sheets("Compiled").Rows.Count, "A").End(xlUp).Row
With Sheets(i)
.Range(.Cells(2, "A"), .Cells(lastRowSource, "AB")).Copy Sheets("Compiled").Range(Sheets("Compiled").Cells(lastRowDest + 1, "A"), Sheets("Compiled").Cells(lastRowDest + 1 + lastRowSource, "AB"))
End With
End If
Next i
' delete blank rows
End Sub
I tried this code from an older question to delete the blank rows, which gave me an "out of range" error:
Dim myWs As Worksheet
Set myWs = ThisWorkbook.Worksheets("Compiled") 'set your sheet name
Dim lastRow As Long
lastRow = myWs.Range("A" & myWs.Rows.Count).End(xlUp).Row 'find last used row
With myWs.Range(myWs.Cells(2, "A"), myWs.Cells(lastRow, "A"))
.Value = .Value 'convert formulas to values whithin the range from with block (column A only)
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'delete rows where column A is blank
End With
The error with this code appears to be at "Dim myWs As Worksheet". This is where I get the "out of range" error. I'm trying to point to the compiled worksheet.
If I am not wrong, you want to combine data from different worksheets into one master sheet. But your code is producing lots of empty rows in the "Compiled" sheet. That's why you want to "remove blank rows from specific range".
What I understand from your code:
you want to:
delete sheets named "Instructions" and "TM Contacts"
add a new sheet "Compiled"
copy header from the table "Table_1" in sheet "<Last Name, First Name>" and paste it as header for sheet "Compiled"
copy data "A2" to "AB & last row" from all sheets to sheet "Compiled", starting from "A2"
Please check if this works:
Here I have tried to avoid .select
Option Explicit
Sub CombineData()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim lastRowDest As Long
Dim lastRowSource As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'delete sheets named "Instructions" and "TM Contacts". also delete "Compiled", if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Instructions").Delete
ActiveWorkbook.Worksheets("TM Contacts").Delete
ActiveWorkbook.Worksheets("Compiled").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'add a new sheet "Compiled"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Compiled"
'copy header from the table "Table_1" in sheet "Last Name, First name" and paste it as header for sheet "Compiled"
'from your code I assume you have a data formatted as a table, "Table_1"
ActiveWorkbook.Worksheets("Last Name, First Name").ListObjects("Table_1").HeaderRowRange.Copy
DestSh.Range("A1").PasteSpecial xlPasteValues
'copy data "A2" to "AB & last row" from all sheets to sheet "Compiled",starting from "A2"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
With DestSh
lastRowDest = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With sh
lastRowSource = .Range("A" & .Rows.Count).End(xlUp).Row
End With
'if you want to change copy range, change here
Set CopyRng = sh.Range("A2:AB" & lastRowSource)
With CopyRng
DestSh.Cells(lastRowDest + 1, "A").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I delete rows based on the date in a column.
The dataset is around 85,000 rows and the macro can take from 30s to 5m+ with constant freezing.
I'm not sure if this is due to poorly written code or the size of the dataset.
Sub DeleteCurrentPeriod()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("Transaction list by date")
ws.Activate
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Insert column, autofill formula for range
Sheets("Transaction list by date").Select
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Selection.AutoFill Destination:=Range("AR2:AR100000"), Type:=xlFillDefault
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$100000").AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$100000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
You can give this a try (use F8 key to run it step by step)
Some suggestions:
Name your procedure and variables to something meaningful
Indent your code (you may use Rubberduckvba.com)
Split the logic in steps
Read about avoiding select and activate here
Code:
Public Sub DeleteCurrentPeriod()
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim transactionSheet As Worksheet
Set transactionSheet = ThisWorkbook.Worksheets("Transaction list by date")
' Turn off autofilter and show all data
transactionSheet.AutoFilterMode = False
' Find last row
Dim lastRow As Long
lastRow = transactionSheet.Cells(transactionSheet.Rows.Count, "AQ").End(xlUp).Row
' Define range to be filtered
Dim targetRange As Range
Set targetRange = transactionSheet.Range("A1:BE" & lastRow)
' Insert column
transactionSheet.Columns("AR:AR").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Add formula & calculate
transactionSheet.Range("AR2:AR" & lastRow).FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Application.Calculate
'Filter on new column for cells matching criteria
transactionSheet.Range("A1:BE" & lastRow).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
transactionSheet.Range("A2:BE" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
'Delete added column and remove filter
transactionSheet.Columns("AR:AR").Delete Shift:=xlToLeft
' Remove filter
transactionSheet.AutoFilterMode = False
'Select A1
Range("A1").Select
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
Let me know if it works
I've just made a couple of changes to how you work out the last row and how you do the calculation, it looks like you were comparing to a constant on the Control sheet. I wonder though why are you adding a column in and then deleting it, could you not just perform the calcs in column +1 after your data? Then you wouldn't have to create and delete the column.
'Insert column, autofill formula for range
Dim x as Long, y, lastrow
Sheets("Transaction list by date").Select
'Find the last row used
With Sheets("Transaction list by date")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
' Get the constant and perform the comparison, add "Y" to TRUE cells
x= Worksheets("Control").Cells(20,7).value
For y = 1 to lastrow
If Worksheets("Transaction list by date").Cells(y,44)>x then _
Worksheets("Transaction list by date").Cells(y,44).value = "Y"
Next y
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$" & lastrow ).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$" & lastrow).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
Sub RemoveDups()
Const COMPARE_COL As Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Worksheets("Sheet1").UsedRange
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Date
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Worksheets("Sheet1").UsedRange = aNew
End Sub
This is an answer written by Tim Williams I just set the range to used range and set v to Date, so if you copy and paste this it will search based on the current date you run the macro looking through column 1 (A) If you want to use a different date you'll have to redefine v, you can make that equal to the cell on your control sheet. Took 1 second to "delete" 85000 rows.
I'm trying to copy a range of rows where the rows chosen are based on the value in one cell.I want to do this for all rows containing the same value in a cell, then move on to the next value an append to the bottom of the first list.
Below is my attempt at explaining what I wish to achieve - hopefully the above will help explain more my dilemma. I have looked around for this but not quite found what I want. I thought it would be simple and probably is.
I receive a data dump with thousands of rows of data and 18 columns. Based on the value of column P "Contract" I want to copy entire rows into a new single worksheet workingdata. Not all the data will go into the workingdata worksheet.
The contract numbers are c1234, c1235, c2345 etc.
What i am after achieving is copying and sorting, so copy all the rows of data where contract number is c1234, in workingdata, then directly below it copy all rows where contract is c1235 and so on.
I thought I could select the range P:P and sort but to no avail.
Sheets("Data Dump").Select
Columns("P:P").Select
If Selection.Value = "C1234" Then
Selection.EntireRow.copy
I know I should post what i have tried, but it would be a pathetic, for some reason I just can't seem to get my head round this one.
Here's my latest effort - I know there are errors
Dim oWorksheet As Excel.Worksheet
Dim oRangeSource As Excel.Range
Dim oRangeDest As Excel.Range
Set oWorksheet = Worksheets("DataDump")
Set oRangeSource = oWorksheet.Range("p:p")
Set oRangeDest = Worksheets("workingdata")
If oRangeSource="CA0004000" Then Select.EntireRow
Selection.EntireRow.copy
Sheets("workingdata").Select.Paste
End If
latest effort but does not sort data or get rid of unwanted, I have to do a manual filter and sort which sorts of defeats the object of the macro
Sub copy()
'
' copy Macro
'
Dim rngContracts As Range: Set rngContracts = Sheets("DataDump").Range("P:P")
Dim wsData As Worksheet
Dim wsFound As Boolean: wsFound = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Working Data" Then
Set wsData = ws
wsFound = True
Exit For
End If
Next ws
If wsFound = False Then
Application.CutCopyMode = False
ActiveSheet.Range("A1").EntireRow.copy
Set wsData = Sheets.Add(After:=Sheets(Sheets.Count))
wsData.Name = "Working Data"
wsData.Range("A1").EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Dim iCell As Range
For Each iCell In rngContracts
If iCell.EntireRow.Hidden = False Then
Application.CutCopyMode = False
iCell.EntireRow.copy
wsData.Range("P" & Rows.Count).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Next iCell
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Latest attaempt - copies the data I need but does not sort:
Sub copytest()
'
' copytest Macro
'
Set MR = Sheets("data Dump").Range("P:P")
For Each cell In MR
If cell.Value = "CA000154" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000220" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000393" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000429" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
Record a macro to set filters on your data select one filter only.
Then, edit the code and loop through each filter copying the visible range on to your sheet. This must also sort your data as the filters are already sorted.
Also, take a look at creating filter arrays in the Excel VBA help with regards to using them to sort.