I want to copying information from two different workbooks into a third. The code below works for B, but for A it pastes only the first row of information.
I set the destination for A to a different tab of the source workbook and it worked. Then I set the destination to a newly created workbook, and also worked.
When I tried again with the workbook I want the information in, it pastes only the first row.
'open file A
Set W_Book = Workbooks.Open(Folder_Path & A_Rep)
Sheets("A").Activate
'filter out information and copy it
With ActiveSheet
.AutoFilterMode = False
.UsedRange.AutoFilter
.UsedRange.AutoFilter Field:=5, Criteria1:=Start_Date
.UsedRange.AutoFilter Field:=10, Criteria1:="AAA10"
.UsedRange.SpecialCells(xlCellTypeVisible).Copy
End With
'paste on the tracker and close the report
Windows("Tracker.xlsm").Activate
Sheets("Sheet A").Range("A1").PasteSpecial
W_Book.Close False
'open file B
Set W_Book = Workbooks.Open(Folder_Path & B_Rep)
'filter out information and copy it
With ActiveSheet
.AutoFilterMode = False
.UsedRange.AutoFilter
.UsedRange.AutoFilter Field:=7, Criteria1:="BBB10"
.UsedRange.AutoFilter Field:=24, Criteria1:="Done"
.UsedRange.SpecialCells(xlCellTypeVisible).Copy
End With
'paste on the tracker and close the report
Windows("Tracker.xlsm").Activate
Sheets("Sheet B").Range("A1").PasteSpecial
W_Book.Close False
This is happening because you are using ActiveSheet when filtering the data, but after you open workbook B, you don't specify a sheet to copy, try the code below and it should give you better results, I specified the first worksheet to copy data from, which you may need to amend:
Sub foo()
Dim wbTracker As Workbook: Set wbTracker = Workbook("Tracker.xlsm")
'open file A
Set W_Book = Workbooks.Open(Folder_Path & A_Rep)
'filter out information and copy it
With W_Book.Sheets("A")
.AutoFilterMode = False
.UsedRange.AutoFilter
.UsedRange.AutoFilter Field:=5, Criteria1:=Start_Date
.UsedRange.AutoFilter Field:=10, Criteria1:="AAA10"
.UsedRange.SpecialCells(xlCellTypeVisible).Copy
End With
'paste on the tracker and close the report
wbTracker.Sheets("Sheet A").Range("A1").PasteSpecial
W_Book.Close False
'open file B
Set W_Book = Workbooks.Open(Folder_Path & B_Rep)
'filter out information and copy it
With W_Book.Sheets(1)
.AutoFilterMode = False
.UsedRange.AutoFilter
.UsedRange.AutoFilter Field:=7, Criteria1:="BBB10"
.UsedRange.AutoFilter Field:=24, Criteria1:="Done"
.UsedRange.SpecialCells(xlCellTypeVisible).Copy
End With
'paste on the tracker and close the report
wbTracker.Sheets("Sheet B").Range("A1").PasteSpecial
W_Book.Close False
End Sub
Related
Receiving Object Variable Error with ActiveSheet.AutoFilter.Range.Copy code line
Any reason why I'm receiving this?
Sub Macro3()
'Create three new sheets with unique names
Sheets.Add.Name = "SOX App-not linked to active KC"
Sheets.Add.Name = "Non SOX App-linked to Active KC"
Sheets.Add.Name = "Active KC - Delisted App"
With Sheets("Report")
.AutoFilterMode = False
With .Range("A1:N20000")
.AutoFilter Field:=7, Criteria1:="Yes"
.AutoFilter Field:=6, Criteria1:=Array("In Development", "In Production", "Projected Retire", "Retain - App and Data", "Retain - Data Only"), Operator:=xlFilterValues
.AutoFilter Field:=11, Criteria1:="Active"
ActiveSheet.AutoFilter.Range.Copy
Sheets("SOX App-not linked to active KC").Select
Range("A1").Select
Sheets("SOX App-not linked to active KC").Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Sheets("SOX App-not linked to active KC").Range("A1").PasteSpecial xlPasteFormats
End With
End With
End Sub
You should not use ActiveSheet there - just
.AutoFilter.Range.Copy
(and move that line up to the sheet With block)
It's already scoped by the With block, and will likely error if "Report" is not the active sheet.
Sub Macro3()
Dim ws As Worksheet
'Create three new sheets with unique names
Set ws = Sheets.Add()
ws.Name = "SOX App-not linked to active KC"
Sheets.Add.Name = "Non SOX App-linked to Active KC"
Sheets.Add.Name = "Active KC - Delisted App"
With Sheets("Report")
.AutoFilterMode = False
With .Range("A1:N20000")
.AutoFilter Field:=7, Criteria1:="Yes"
.AutoFilter Field:=6, Criteria1:=Array("In Development", "In Production", _
"Projected Retire", "Retain - App and Data", _
"Retain - Data Only"), Operator:=xlFilterValues
.AutoFilter Field:=11, Criteria1:="Active"
End With
.AutoFilter.Range.Copy '<<< move this up!
End With
With ws.Range("A1")
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
End With
End Sub
Can someone please let me know why my code is not pasting anything from my source data to my destination file?
The objectives of this code are to select rows that satisfy certain criteria, copy-pastes it into another workbook, The code is shown below:
Sub Copy_Source_LRE()
Dim LastRow As Integer, i As Integer, erow As Integer
Workbooks.Open _
"C:\Users\sjiang\OneDrive - Canada Pension Plan Investment Board\Desktop\IOA Exposure\AAPAF_strategy_loadings_2019-04-01_2020-04-01 (2).csv"
Worksheets("AAPAF_strategy_loadings_2019-04").Activate
Set sht = ActiveSheet
'Workbooks("AAPAF_strategy_loadings_2019-04-01_2020-04-01 (2).csv").Sheets("AAPAF_strategy_loadings_2019-04").Activate
LastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRow
For Each d In Array("4/1/2019", "5/1/2019", "6/3/2019", "7/1/2019", "8/1/2019", "9/2/2019", _
"10/1/2019", "11/1/2019", "12/2/2019", "1/2/2020", "2/3/2020", "3/2/2020")
If Cells(i, 2) = d And Cells(i, 3) = "Real Estate" And Cells(i, 4) = "Listed Real Estate" And Cells(i, 5) = "AAPAF_SA" Then
Range(Cells(i, 2), Cells(i, 12)).Select
Selection.Copy
Workbooks.Open _
"C:\Users\sjiang\OneDrive - Canada Pension Plan Investment Board\Desktop\IOA Exposure\pull data.xlsm"
Worksheets("Sheet1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
'ActiveWorkbook.Close
End If
Next d
Next i
Application.CutCopyMode = False
End Sub
This is a really easy and basic way that I use all the time to copy data into new workbooks. In this example I'm copying a named range called "MasterData" into a new blank workbook. Then I save that new book with a password and re-activate the current workbook.
Dim newfilename As String
newfilename = "/Users/" & userName & "/Desktop/savedWorkbook.xlsx"
Dim NewBook As Workbook
Set NewBook = Workbooks.Add
ThisWorkbook.Activate
Sheets("Datasheet").Select
Range("MasterData").Copy
NewBook.Activate
NewBook.Sheets(1).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NewBook.SaveAs Filename:=newfilename, Password:="examplepassword", AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
NewBook.Close (True)
ThisWorkbook.Activate
I've redone the code for you as the major problem was related to a loop that is not really necessary. The best/fast way to apply those criteria and extract the data is using a filter to apply them, so copy the visible cells without the hidden (unmatching) lines and then open the second file where you need to past info, find next blank line below selection and paste all lines at once.
I'm pasting the code below (with comments) and also saved a zip file with 3 files (code, info, database) that might reflect your working files, link below.
VBS code:
Sub Copy_Source_LRE()
Dim LastRow As Integer, i As Integer, erow As Integer
Workbooks.Open ThisWorkbook.Path & "\" & "Wks1.xlsx" 'change the path and name here
Worksheets(1).Activate
Set sht = ActiveSheet
LastRow = Range("a1").SpecialCells(xlCellTypeLastCell).Row
datar = Range(Cells(LastRow, 12), Cells(1, 1)).Address 'data range
Range(datar).Select
Selection.AutoFilter 'create a filter,then use the criteria you need
ActiveSheet.Range(datar).AutoFilter Field:=2, Criteria1:= _
Array("4/1/2019", "5/1/2019", "6/3/2019", "7/1/2019", "8/1/2019", "9/2/2019", _
"10/1/2019", "11/1/2019", "12/2/2019", "1/2/2020", "2/3/2020", "3/2/2020"), Operator:=xlFilterValues 'your dates array can be update here
ActiveSheet.Range(datar).AutoFilter Field:=3, Criteria1:="Real Estate", Operator:=xlAnd
ActiveSheet.Range(datar).AutoFilter Field:=4, Criteria1:="Listed Real Estate", Operator:=xlAnd
ActiveSheet.Range(datar).AutoFilter Field:=5, Criteria1:="AAPAF_SA", Operator:=xlAnd
Range(datar).Offset(1, 0).Resize(Range(datar).Rows.Count - 1, Range(datar).Columns.Count).Select 'resize selection to remove the header
Selection.SpecialCells(xlCellTypeVisible).Select 'select visible cells only
Selection.Copy
Workbooks.Open ThisWorkbook.Path & "\" & "Wks2.xlsx" 'change the path and name here
Worksheets("Sheet1").Select
Range("A1").End(xlDown).Offset(1, 0).Select 'goes to the last row on column A the goes another one - 1st empty
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close SaveChanges:=True 'close and save your database
Application.CutCopyMode = False
ActiveWorkbook.Close SaveChanges:=False 'close without saving your csv file
End Sub
link to files/code: https://drive.google.com/file/d/1zL_TwclHR4lrNhKB1xODGAmliPHM1r3K/view?usp=sharing
If the solution matches you need please consider as solution. Regards!
I have a VBA code which copies same data from Multiple sheet and then paste it in "Main" Sheet. It then auto fills the blank cells for values from above and then it delete all the rows Where H:H is blank. However being novice in VBA, i feel my code has too many loops, which makes it run slower. Moreover if have the "Main" Sheet have a table formatted, the code does not delete any row H is blank. However it works if "Main" is blank and not formatted.
Another thing I found out that after the code is executed, the excel sheet becomes less responsive. I cannot select cells quickly, change between sheets.
Please advise if anything can be improved to make it run more efficiently.
Private Sub CopyRangeFromMultiWorksheets1()
'Fill in the range that you want to copy
'Set CopyRng = sh.Range("A1:G1")
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim rng As Range
Dim Last As Long
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng4 As Range
Dim CopyRng5 As Range
Dim CopyRng6 As Range
Dim CopyRng7 As Range
Dim cell As Range
Dim Row As Range
Dim LastrowDelete As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
'Application.DisplayAlerts = False
On Error Resume Next
'ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
'Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = Sheets("Main")
'Set DestSh = ActiveWorkbook.Worksheets.Add
' DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name And sh.Name <> "PAYPERIOD" And sh.Name <>
"TECHTeamList" Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng1 = sh.Range("B3")
Set CopyRng2 = sh.Range("C3")
Set CopyRng3 = sh.Range("D3")
Set CopyRng4 = sh.Range("G3")
Set CopyRng5 = sh.Range("C5")
Set CopyRng6 = sh.Range("A8:j25")
Set CopyRng7 = sh.Range("A28:j45")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng1.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this
macro
CopyRng1.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng2.Copy
With DestSh.Cells(Last + 1, "B")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng3.Copy
With DestSh.Cells(Last + 1, "C")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng4.Copy
With DestSh.Cells(Last + 1, "D")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng5.Copy
With DestSh.Cells(Last + 1, "E")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng6.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
'Refresh the Lastrow used so that the values start from
'underneath copyrng6
Last = LastRow(DestSh)
CopyRng7.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
'Autofill the rang A2:E for values from above looking at the last row of F
With Range("A2:E" & Range("F" & Rows.Count).End(xlUp).Row)
.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
'Delete Entire rows where H is Blank
Application.ScreenUpdating = False
Columns("H:H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Any Help would be appreciated.
I am working on a project where I filter column CI for "No" and "N/A", and if there are any results I want to copy the data in A:CD from the corresponding rows. How can I select the data in A:CD? I am working with 50,000+ rows of data so any offset loops would slow down the program too much. The last line of code before the End With is definitely incorrect.
Sub selectdata()
Sheets("Sheet_1").Select
Range("A1:CD1", Range("A1:CD1").End(xlDown)).Copy
Sheets("Sheet_2").Select
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats,
_
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("CE2:CP2").AutoFill Destination:=Range("CE2:CP" & Cells(Rows.Count,
"D").End(xlUp).Row)
Range("CI1").Select
Selection.AutoFilter Field:=87, Criteria1:=Array( _
"NO", "N/A"), Operator:=xlFilterValues
With ActiveSheet
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 _
Then .Resize(.Rows.Count - 1, 1).Offset(1, -5).xlLeft.Copy
End With
End Sub
Thanks!
To copy filtered data in A:CD
With ActiveSheet
With Intersect(.Range("A:CD"), .UsedRange)
.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy
End With
End With
Try this... it copies without header to CE2.
You can alter your filter with this method by adjusting this line
filterRange.AutoFilter Field:=87, Field:=87, Criteria1:="=N/A", Operator:=xlOr, Criteria2:="=NO"
Code:
Option Explicit
Sub selectdata()
Dim sourceWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Set sourceWorkbook = ThisWorkbook
Set sourceSheet = sourceWorkbook.Worksheets("Sheet1")
Set targetSheet = sourceWorkbook.Worksheets("Sheet2")
With sourceSheet
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "CI").End(xlUp).Row
Dim filterRange As Range
Set filterRange = .Range("A1:CI" & lastRow)
filterRange.AutoFilter
filterRange.AutoFilter Field:=87, Field:=87, Criteria1:="=N/A", Operator:=xlOr, Criteria2:="=NO"
With sourceSheet.AutoFilter.Range
.Offset(1, 0).Resize(.Rows.Count - 1, 82).SpecialCells(xlCellTypeVisible).Copy targetSheet.Range("CE2")
End With
End With
End Sub
I am new to the VBA and Macro world. I am trying to create a data collection sheet. First part data is collected in from 1 workbook and placed in workbook master. What I would like to achieve is the new data that I extract will be placed below the previous entry in the workbook master.
Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
Sheets("For Coordinator Use").Select
Range("A2:M41").Select
Selection.Copy
Windows("Nimble Schedule Import Template- ops.xlsx").Activate
Range("A1000").End(xlUp).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
"=0", Operator:=xlOr, Criteria2:="="
Application.CutCopyMode = False
Selection.EntireRow.Delete
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
Windows("Coverage Request Form (9).xlsx").Activate
Sheets("Request Form").Select
End Sub
Here is a modified and commented copy of your code:
Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
Sheets("For Coordinator Use").Select
Range("A2:M41").Copy 'No need to select then copy, just copy is fine
Windows("Nimble Schedule Import Template- ops.xlsx").Activate
'I have offset the last row of data by 1 row below, use rows.count rather than a hard row number. Also no need to select
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="="
'I don't know what row is selected here but it was in your code so I left it, also no need for cutcopymode as it will cancel when you delete anyway
Selection.EntireRow.Delete
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
Windows("Coverage Request Form (9).xlsx").Activate
Sheets("Request Form").Select
End Sub
Please read the comments and ask any questions about it where you are unsure. These changes are because you have stipulated you are new to this and I don't want to confuse you, this is NOT the best way to do it, I would much rather set up something with arrays than a copy and paste. If you are comfortable with this concept post back and I will modify my code for you.
It depends how you would like to do it. Do you want to maybe use an array to store the data in then extract to the master spreadsheet or do you want to just use excels built in functions to copy and paste the data like you are doing above. You could also use a scripting dictionary to store the data as well there are many ways to do it just wondering which route you want to take. If you want to have a high performance macro then I suggest not to use excel's built in functions as they are slower than using arrays.
Update 2015-08-20
I have got the copy and paste using the range object. However I see you want to delete some other values from your list although they are kept in a table and not in a spreadsheet. Is this correct? Please have a look at the code I made some comments asking for some clarifications. Sorry for taking so long I was busy finishing something up at work.
Sub Extract() ' ' Extract Macro ' ' Keyboard Shortcut: Ctrl+e '
Dim wb As Workbook, ws As Worksheet, rng As Range
Set wb = ThisWorkbook 'Set up the Excel objects you want to use
Set ws = wb.Worksheets("For Coordinator Use")
Set rng = ws.Range("A2:M41") 'asuming this is not changing
'Sheets("For Coordinator Use").Select 'You do not need to select if you use the objects
'Range("A2:M41").Select 'You do not need to select if you use the objects
'Selection.Copy 'you can also get rid of this if using objects
Dim wbDest As Workbook, wsDest As Worksheet, rngDest As Range
Set wbDest = Application.Workbooks("Nimble Schedule Import Template- ops.xlsx") ' Assuming that it is opened
'Windows("Nimble Schedule Import Template- ops.xlsx").Activate 'dont need to activate anything
Set wsDest = wbDest.Worksheets("Sheet1")
Set rngDest = wsDest.Range("A1:A35000")
''optimize the application
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
''''
'''Find the first empty cell in destRng
'Range("A1000").End(xlUp).Select ' this will select the range that is blank only if it does not have data to begin with
Dim i As Long, j As Long, rngAdd As String 'i is the counter and j stores the row where it is blank
For i = 1 To rngDest.Cells.Count
If IsEmpty(rngDest.Cells(i, 1).Value) Then
j = i
i = rngDest.Cells.Count
End If
Next i
'reset the rngDest
Set rngDest = Nothing
rngAdd = "A" & j & ":M" & (j + 39)
Set rngDest = wsDest.Range(rngAdd)
'make rngDest = rng.Value since they have the same dimension this works
rngDest = rng.Value 'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
' :=False, Transpose:=False
'I am not sure what you are trying to acheive here a filter??'ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
' "=0", Operator:=xlOr, Criteria2:="="
'Application.CutCopyMode = False
'Selection.EntireRow.Delete
'ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
''Looks like you are deleting all with a value of "=0"
'Windows("Coverage Request Form (9).xlsx").Activate
'Sheets("Request Form").Select
'Release Objects
Set rngDest = Nothing
Set wsDest = Nothing
Set wbDest = Nothing
Set rng = Nothing
Set ws = Nothing
Set wb = Nothing
''set excel optimization as normal again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAuto
Application.EnableEvents = True
End Sub