I have the following code that copies one worksheet to another and pastes only values however the code that protects the sheet is not working? what am I doing wrong here?
Sub GetQuote()
Range("AK548").Select
Selection.Copy
Range("AK549").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim ws As Worksheet
Dim sDataOutputName As String
With Application
.Cursor = xlWait
.StatusBar = "Saving Quote & Proposal Sheet..."
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("Quote & Proposal")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
sDataOutputName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Quote Questions").Range("AK545").Value & ".xlsx"
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs sDataOutputName
ActiveWorkbook.Protect Password:="12345"
ActiveWorkbook.Close SaveChanges:=False
.Cursor = xlDefault
.StatusBar = False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
You are protecting the workbook and setting the password, on the next line of code you closing the workbook but not saving the changes.
Your code is showing work book protection, not work sheet protection. If you want to protect the sheet, use worksheet protection:
ws.Protect Password:="12345", DrawingObjects:=True, Contents:=True, Scenarios:=True
'ADD AND REMOVE PARAMETERS AS YOU WANT THEM
I put in: ActiveSheet.Protect Password:="12345" just above the line of code: ActiveWorkbook.SaveCopyAs sDataOutputName and it worked!
Related
I want to open files from a specific folder and do the actions with my code below.
But when VBA opens the first file, it stops.
Please help me!
Sub ExtractData?()
'
' ExtractData? Macro
'
' Keyboard Shortcut: Ctrl+Shift+Q
'
Dim buf As String
Dim dlg As FileDialog
Dim fold_path As String
Application.ScreenUpdating = False
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
If dlg.Show = False Then Exit Sub
fold_path = dlg.SelectedItems(1)
buf = Dir(fold_path & "\*.xlsx")
Do While buf <> ""
Workbooks.Open fold_path & "\" & buf
Sheets("データセット1").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Workbook.xlsm").Activate
Sheets("GE").Select
Cells(Range("A65536").End(xlUp).Row + 1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks(buf).Close SaveChanges:=False
buf = Dir()
Loop
End Sub
The error is not coming from your Do While buf <> "" loop, but from what you are trying to achieve inside (copy >> paste between workbooks).
Inside your loop, you have too many Select, Selection and Activate, instead use fully qualifed Range and Cells.
You can use With openWB.Worksheets("データセット1"), and below it nest your range with .Range(.Cells(2, "A"), .Cells(LastRow, LastCol)).Copy.
Code
Sub ExtractData①()
' ExtractData? Macro
' Keyboard Shortcut: Ctrl+Shift+Q
'
Dim buf As String
Dim dlg As FileDialog
Dim fold_path As String
Dim openWB As Workbook
Dim LastRow As Long, LastCol As Long
Application.ScreenUpdating = False
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
If dlg.Show = False Then Exit Sub
fold_path = dlg.SelectedItems(1)
buf = Dir(fold_path & "\*.xlsx")
Application.DisplayAlerts = False
Do While buf <> ""
Set openWB = Workbooks.Open(fold_path & "\" & buf) '<-- set open workbook to object
With openWB.Worksheets("データセット1") '<-- not sure about this name (I don't have this font)
' set the range from A2 to last cell with data in sheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, "A"), .Cells(LastRow, LastCol)).Copy
End With
' if "Workbook.xlsm" is this workbook with the code, could be repalced with ThisWorkbook
With Workbooks("Workbook.xlsm").Worksheets("GE")
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
openWB.Close False
buf = Dir()
Loop
' restore settings
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
While your code works for me, using Select, Selection and Activate is pretty prone to error, especially when used in loops or when working in several workbooks.
Using nested With Objects makes it saver, faster and readable without forcing you to Dim and Set a ton of object variables. Try this:
On Error Goto catch:
try:
With Workbooks.Open(fold_path & "\" & buf)
With .Sheets("データセット1").Range("A2")
Range(.Cells(1, 1).End(xlToRight), .End(xlDown)).Copy
End With
With ThisWorkbook.Sheets("GE")
.Cells(Range("A65536").End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
finally:
.Close SaveChanges:=False
End With
' rest of your code
Exit Sub
catch:
Debug.Print "Err at File " & buf & vbCrLf & Err & vbTab & Error
GoTo finally
Addidional notes:
.End(...) will get wrong results if there is an empty cell on the left or top border of your data range.
above is a simple example of an error handling routine, using pseudo try, catch, finally. Make sure you don't create any infinite loops (meaning: only execute bullet-proof code after the finally and add Exit Sub above the catch:
there are rare cases where the use of .Copy and .PasteSpecial makes sense.
However, in your case it's save to assume that there are simpler, faster and more fail proof options:
Range1.Value = Range2.Value, which writes the data in one step (therefore it's not simply screwed by user interactions, like .Copy + .Paste is
Read the data into an Array or better a Recordset, which allows additional processing, like filtering out empty rows
pull data with an ADO.Connection and SQL, which, you guessed it, allows even simpler processing and doesnt need the .Open + .Close and switching between workbooks
Hope that helps!
I use vba to import data from one wb to another - but it seems like the data is not overwriten.
ex.
wb 1 cell A2 contains the number "2" and is copied to wb 2 cell A2.
But if I delete cell A2 from wb 2, and run the vba again - there is no data entered in wb 2 cell A2...
Can anyone see why this is?
Regards
Brian
Sorry forgot to add code :o)
Sub GetData()
Dim strWhereToCopy As String, strStartCellColName As String
Dim strListSheet As String
Application.ScreenUpdating = False
strListSheet = "List"
On Error GoTo ErrH
Sheets(strListSheet).Select
Range("B2").Select
'this is the main loop, we will open the files one by one and copy their data into the masterdata sheet
Set currentWB = ActiveWorkbook
Do While ActiveCell.Value <> ""
strFileName = ActiveCell.Offset(0, 1) & ActiveCell.Value
strCopyRange = ActiveCell.Offset(0, 2) & ":" & ActiveCell.Offset(0, 3)
strWhereToCopy = ActiveCell.Offset(0, 4).Value
strStartCellColName = Mid(ActiveCell.Offset(0, 5), 2, 1)
Application.Workbooks.Open strFileName, UpdateLinks:=False, ReadOnly:=True
Set dataWB = ActiveWorkbook
Range(strCopyRange).Select
Selection.Copy
currentWB.Activate
Sheets(strWhereToCopy).Select
lastRow = LastRowInOneColumn(strStartCellColName)
Cells(lastRow + 1, 1).Select
Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
dataWB.Close False
Sheets(strListSheet).Select
ActiveCell.Offset(1, 0).Select
Loop
Sheets(strListSheet).Select
Range("B2").Select
Exit Sub
ErrH:
MsgBox "It seems some file was missing. The data copy operation is not complete."
Exit Sub
'Application.ScreenUpdating = True
End Sub
you can copy wb1 and past it as wb2
Sub Copy_One_File()
Dim wb1, wb2 As String
wb1 = ActiveWorkbook.Path & "wb1.xlsm"
wb2 = ActiveWorkbook.Path & "wb2.xlsm"
FileCopy wb1, wb2
End Sub
this is the simplest method
you should avoid Select/Selection/Activate/ActiveXXXpattern in favour of a fully qualified range reference
like in the following (commented) code:
Option Explicit
Sub GetData()
Dim strWhereToCopy As String, strStartCellColName As String
Dim strFileName As String
Dim strCopyRange As Range, cell As Range
Dim LastRow As Long
With Sheets("List") '<--| reference your "List" worksheet
For Each cell In .Range("B2", .Cells(.Rows.count, "B").End(xlUp)).SpecialCells(xlCellTypeConstants) '<--| loop through its column "B" not empty cells form row 2 down to last not empty one
With cell '<--| reference current cell
strFileName = .Offset(0, 1) & .Value
strCopyRange = .Offset(0, 2) & ":" & .Offset(0, 3)
strWhereToCopy = .Offset(0, 4).Value
strStartCellColName = Mid(.Offset(0, 5), 2, 1)
End With
On Error GoTo ErrH '<--| activate error handler for subsequent file open statement
Workbooks.Open strFileName, UpdateLinks:=False, ReadOnly:=True
On Error GoTo 0 '<--| resume "default" error handling
Range(strCopyRange).Copy '<-- without a leading dot (.) the range referes to the currently active worksheet, which is the active one in the just opened workbook
With .Parent '<--| reference workbook where currently referenced Sheet "List" resides in
LastRow = LastRowInOneColumn(.Worksheets(strWhereToCopy), strStartCellColName) '<--| your 'LastRowInOneColumn' function must be passed a worksheet reference, too
With .Worksheets(strWhereToCopy).Cells(LastRow + 1, 1) '<--| reference 'strWhereToCopy' named worksheet in the referenced workbook
.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
End With
ActiveWorkbook.Close False
Next cell
.Activate
.Range("B2").Select
End With
Exit Sub
ErrH:
MsgBox "It seems some file was missing. The data copy operation is not complete."
End Sub
as per comments, your LastRowInOneColumn function must be passed a worksheet object reference too and fully qualify the column range reference to search the last row in
the function signature and its pseudocode is:
Function LastRowInOneColumn(sht As Worksheet, strStartCellColName As String) As Long
With sht
'here goes your actual 'LastRowInOneColumn' code
' only you have to put a dot (.) before each range reference
End With
End Function
I am currently having an issue getting the data from one sheet to paste special into another sheet, I am trying to consolidate multiple files (same headers, differing number of rows) into one master sheet containing all the rows. At the moment I'm doing that by opening all the files, pulling in the tabs I want, copy and pasting the data, and then deleting the tabs. Yes I am sure there is an easier way, but I'm very new to VBA and am learning on the fly..here's what I have so far:
Sub ConsolidateSheets()
' open each file in folder
Dim Folder As String
Dim Files As String
Folder = "C:\Users\212411103\Documents\Risk Project Tracker\Risk Project Tracker Monthly\Monthly Data"
Files = Dir(Folder & "\*.xls")
Do While Files <> ""
Workbooks.Open Filename:=Folder & "\" & Files
Files = Dir
Loop
' pull in Risk Project Tracker tab from each file to new workbook
Dim wkb As Workbook
Dim sWksName As String
sWksName = "Risk Project Tracker"
For Each wkb In Workbooks
If wkb.Name <> ThisWorkbook.Name Then
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
End If
Next
Set wkb = Nothing
Dim J As Integer
' add new sheet for combined data
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "New Month"
' paste headers from first two rows into new sheet "New Month"
Sheets(2).Select
Range("A1:AH2").Select
Selection.Copy
Sheets("New Month").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("A1").Select
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
Sheets(J).Activate ' make the sheet active
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Range("A1:AH500").Select
Selection.Copy
Sheets("New Month").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
Next
' Delete tabs that are no longer needed i.e. the tabs from the 17 files
' For Each ws in Sheets
' Application.DisplayAlerts=False
' If ws.Name <> "New Month" Then ws.delete
' Next
' Application.DisplayAlerts=True
End Sub
It appears that the primary reason you are specifying the Range .PasteSpecial method is the carry-over of column widths which is done for every tab. Perhaps cycling through A:AH once and setting the column widths should be sufficient.
Sub ConsolidateSheets2()
Dim fldr As String, fn As String, sWksName As String, sNewWksName As String
Dim ws As Worksheet, wkb As Workbook
On Error GoTo bm_Safe_Exit
Application.ScreenUpdating = False
Application.EnableEvents = False
sWksName = "Risk Project Tracker"
fldr = "C:\Users\212411103\Documents\Risk Project Tracker\Risk Project Tracker Monthly\Monthly Data"
fn = Dir(fldr & "\*.xls")
sNewWksName = "New Month"
With ThisWorkbook
Do While fn <> ""
Set wkb = Workbooks.Open(Filename:=fldr & Chr(92) & fn)
If IsObject(wkb.Worksheets(sWksName)) Then
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1 - CBool(Sheets(1).Name = sNewWksName))
On Error GoTo bm_Need_New_Month_ws
With .Worksheets(sNewWksName)
On Error GoTo bm_Safe_Exit
.Parent.Sheets(2).Range("A3:AH502").Copy _
Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
End If
wkb.Close False
fn = Dir
Loop
Application.DisplayAlerts = False
Do While Sheet.Count > 1: Sheets(2).Delete: Loop
End With
GoTo bm_Safe_Exit
bm_Need_New_Month_ws:
If Err.Number = 9 Then
With ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Sheets(1))
.Name = sNewWksName
.Move Before:=Sheets(1)
.Parent.Sheets(2).Range("A1:AH2").Copy _
Destination:=.Range("A1")
For c = .Columns("AH:AH").Column To 1 Step -1
.Columns(c).ColumnWidth = _
.Parent.Sheets(2).Columns(c).ColumnWidth
Next c
End With
Resume
End If
bm_Safe_Exit:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Background:
I'm recording a macro in Excel that transfers data between three different workbooks that are all open at the same time (I'm recording it and then going into the code and fixing any bugs because I have zero experience with coding).
Problem:
Two of the workbooks will always be used while the third changes (ex. RFQ_1234, RFQ_1235). The macro works great, except each time I use it, I have to debug it and re-enter the name of the third workbook. How do I change my code so that it references the 3rd workbook without using a specific name?
Disclaimer:
I know .select is super slow, I don't care. It just needs to work. Also, I know very little about coding, so please explain even the smallest details.
Example of code:
Windows("RFQ_14446.xlsm").Activate
Range("J51").Select
Selection.Copy
Windows("Transfer Template.xlsm").Activate
Range("B1").Select
ActiveSheet.Paste
Windows("RFQ_14446.xlsm").Activate
Range("D27").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Transfer Template.xlsm").Activate
Range("B2").Select
ActiveSheet.Paste
Windows("RFQ_14446.xlsm").Activate
Range("D5").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Transfer Template.xlsm").Activate
Range("B3").Select
ActiveSheet.Paste
Changing as little of your code as possible (as requested!)...
Sub Tester()
Dim wbName As String
wbName = GetRfqWbName("RFQ_")
If Len(wbName) = 0 Then
MsgBox "Didn't find the RFQ workbook!"
Exit Sub
End If
Windows(wbName).Activate
Range("J51").Select
Selection.Copy
Windows("Transfer Template.xlsm").Activate
Range("B1").Select
ActiveSheet.Paste
Windows(wbName).Activate
Range("D27").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Transfer Template.xlsm").Activate
Range("B2").Select
ActiveSheet.Paste
Windows(wbName).Activate
Range("D5").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Transfer Template.xlsm").Activate
Range("B3").Select
ActiveSheet.Paste
End Sub
'get the name of the first workbook which begins with sName...
Function GetRfqWbName(sName As String) As String
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name Like sName & "*" Then GetRfqWbName = wb.Name
Exit For
Next wb
End Function
EDIT: here's an improved version of the Tester sub above
Sub Tester2()
Dim wbName As String, shtSrc As Worksheet, shtDest As Worksheet
wbName = GetRfqWbName("RFQ_")
If Len(wbName) = 0 Then
MsgBox "Didn't find the RFQ workbook!"
Exit Sub
Else
'for example: you can substitute the sheet names instead
Set shtSrc = Workbooks(wbName).Sheets(1)
Set shtDest = Workbooks("Transfer Template.xlsm").Sheets(1)
End If
shtSrc.Range("J51").Copy shtDest.Range("B1")
shtSrc.Range("D27").Copy shtDest.Range("B2")
shtSrc.Range("D5").Copy shtDest.Range("B3")
End Sub
You can reference it by index or activesheet.
Dim ws as Excel.Worksheet
ws = Workbook.ActiveSheet
ws.Cell(A1).Value = "SomeValue"
Or you can use the index.
Set ws = ExcelApplication.Worksheets(1)
I am new to VBA and have been using the site to piece together a solution.
I need to write a macro that prompts the user to open a file (wb2), copy a row of data from a Sheet1 in that workbook (wb2) and then paste it into the next empty row within the original workbook (wb) also on Sheet1. I got it to work up until I tried adding the code for pasting in the next empty row - I am now receiving the following error message, "Run-time error '438': Object doesn't support this property or method"
Any help would be greatly appreciated.
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set selectedworkbook
Set wb2 = ActiveWorkbook
wb2.Range("A3:E3").Select
Selection.Copy
wb.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
wb2.Close
'Set targetworkbook
Set wb = ActiveWorkbook
End Sub
Just a quick note on the subject:
Instead of
wb2.Worksheets("Output").Range("J3:R3").Select
Selection.Copy
try
wb2.Worksheets("Output").Range("J3:R3").Copy
Also
Instead of
wb.Worksheets("Master").Range("C" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
try
wb.Worksheets("Master").Range("C" & LastCellRowNumber).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Often times, Select creates unexplainable errors. Particularly when working with multiple workbooks, try to stay away from Select. This code comes almost directly from working code I have. Let us know if this doesn't fix the problem.
I re-worked the code and got it working. It's probably not the cleanest way to do it, but given my timeline and lack of VBA knowledge, it will have to do.
Many thanks to engineersmnky for their help.
Description: This code should be put into the worksheet you want to paste content into from another workbook. When it runs it will prompt you to open a workbook to copy from ("Output" worksheet), it will then select the cells you specify in the code (JR:R3), paste them in starting at the next empty row of your initial workbook (finding the last row in column C in the "Master" worksheet), and then it will close & save the workbook you just copied from.
Sub CommandButton1_Click()
'Last cell in column
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Master")
With WS
Set LastCell = .Cells(.Rows.Count, "C").End(xlUp)
LastCellRowNumber = LastCell.Row + 1
End With
Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set selectedworkbook
Set wb2 = ActiveWorkbook
'Select cells to copy
wb2.Worksheets("Output").Range("J3:R3").Select
Selection.Copy
'Go back to original workbook you want to paste into
wb.Activate
'Paste starting at the last empty row
wb.Worksheets("Master").Range("C" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
'Close and save the workbook you copied from
wb2.Save
wb2.Close
End Sub
Have you tried this
Selection.Copy
wb.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues