I have an Excel macro that creates another workbook for the user to modify. When I try to enter data in a cell in the new workbook, however, I get the error "The cell or chart you're trying to change is on a protected sheet." The sheet in the macro workbook is, in fact, protected, but that sheet is not visible at the time I get the error. When I try to close the visible, newly created workbook, it’s the macro workbook that closes. The last thing my macro does is activate the sheet in the new workbook. What do I have to do to make that work? Having the macro close its own workbook solves the problem, of course, but that’s not what I want to do, since the user needs another macro in the same workbook to process the changes on the new sheet.
The program has over 6000 lines of code (so far), but here is one of the routines that causes the problem.
Private Sub z3_BudgetPrepUpd()
'Build a new workbook initialized to let the user modify data
'for an existing fiscal-quarter budget.
'When this routine executes,
' UserForm1 is still active.
Dim strTracer As String 'error-handling tracer for this subroutine
Dim strFyrQtr As String
On Error GoTo abend
If blnAbort Then Exit Sub
If blnAbortGlobal Then Exit Sub
'Find out which ListBox item the user selected:
If UserForm1.ListBox1.ListCount < 1 Then GoTo aa9000 'ListBox is empty
If UserForm1.ListBox1.ListIndex < 0 Then 'No item selected
strMsgTitle = udtPrm.msgTtl
strMsgPrompt = "Please select a fiscal quarter to update."
Call z0_MsgBox
GoTo aa9000
End If
strFyrQtr = UserForm1.ListBox1.Value 'Selected item in ListBox
'Close UserForm1:
UserForm1.Hide
ThisWorkbook.Sheets(c_WKS_WELCOME).Activate
'Build the udtBgt() array with data for the specified quarter:
lngBgtHiNdx = -1
Call zz_GetBudgetForQtr(strFyrQtr)
If blnAbort Then GoTo aa9000
'Build a new workbook for the user to update budget amounts:
Workbooks.Add
Set wkbNewBook = ActiveWorkbook
'Save the names of the default worksheets
'so we can delete them later:
strDfltSheets() = z0_SheetNames(wkbNewBook)
'Build a worksheet with data from the udtBgt() array:
Call z3_BuildBudgetUpdSheet
If blnAbort Then GoTo aa9000
'Delete the default worksheets:
Call z0_DeleteSheets(wkbNewBook, strDfltSheets())
If blnAbort Then GoTo aa9000
wkbNewBook.Sheets(c_WKS_IPT_BUDGET).Activate
'Excel 2016 Bug:
'We need to close ThisWorkbook to allow the user
'to work with the book we just created:
Application.DisplayAlerts = False
ThisWorkbook.Close
aa9000:
Exit Sub
abend:
lngErr = Err.Number
strErr = Err.Description
blnAbort = True
Application.Cursor = xlDefault 'no more hourglass
strMsgTitle = "Program Error"
strMsgPrompt = "The following error occurred:" & Chr(10) & Chr(10) & _
"Error No. " & CStr(lngErr) & Chr(10) & _
"Error Description: " & strErr & Chr(10) & _
"Subroutine: z3_BudgetPrepUpd" & Chr(10) & _
"Tracer: " & strTracer
Call z0_MsgBox
Resume aa9000
End Sub
You use ThisWorkbook which I agree with. You use ActiveWorkbook which I hardly ever use.
I'd recommend using a variable to store reference to workbooks other than that which houses your code. So use
Dim wb As Excel.Workbook
Set wb = Application.Workbooks.Open("c:\test.xlsm") 'for opening
'* or
Set wb = Application.Workbooks.Add 'for creating a new one
'* or
Set wb = Application.Workbooks.Item("AlreadyOpen.xlsm") 'for referencing one already open
'* from hereon use wb instead of ActiveWorkbook
wb.Worksheets.Item(1).Visible = True
Thanks, everyone, for your interest and suggestions. I have solved the problem by redesigning the application without UserForms or external workbooks. Office 2016 has many issues, and perhaps this is one of them. In any case, I have no more time to research it.
Related
Wrote some code below to help me save some time saving files, the below is the shorter version which only saves one worksheet.
Sometimes it works perfectly, but most of the time it just silently crashes Excel with no error warning.
Nothing wrong while debugging... Not sure if ThisWorkbook.Sheets might be causing the issue?
Sub Save_CPC()
'Define the sheets to copy
Dim sheetsToCopy As Variant
sheetsToCopy = Array("RWF CPC")
'Create a new workbook
Dim newWorkbook As Workbook
Set newWorkbook = Workbooks.Add
'Loop through the sheets to copy
For i = 0 To UBound(sheetsToCopy)
'Copy the sheet to the new workbook
ThisWorkbook.Sheets(sheetsToCopy(i)).Copy Before:=newWorkbook.Sheets(1)
Next i
'Break links in the new workbook
newWorkbook.BreakLink Name:=ThisWorkbook.Name, Type:=xlExcelLinks
'Hide the sheet Sheet1 in new workbook
newWorkbook.Sheets("Sheet1").Visible = False
'Save the new workbook in the original folder
Dim saveName As String
saveName = ThisWorkbook.Sheets("Macros").Range("B13").Value
newWorkbook.SaveAs ThisWorkbook.Path & "\" & saveName & ".xlsx"
End Sub
Thanks in advance!!
Should copy and save worksheet as new spreadsheet with given name in current folder.
Copy Worksheets To a New Workbook
In One Go
Note that you can copy all the worksheets in one go as suggested by BigBen in the comments:
ThisWorkbook.Sheets(sheetsToCopy).Copy
Dim NewWorkbook As Workbook: Set NewWorkbook = Workbooks(Workbooks.Count)
The major drawback is that the worksheets in the new workbook will appear in the order they are appearing in the old workbook which may not necessarily be the order they are appearing in the array.
Additionally, at least one of the worksheets needs to be visible, and very hidden worksheets will not be copied.
Loop
Option Explicit
Sub SaveCPC()
' Start error-handling routine.
On Error GoTo ClearError
' Populate an array with the names of the worksheets to copy.
Dim sheetsToCopy() As Variant: sheetsToCopy = VBA.Array("RWF CPC")
' 'VBA.' ensures a zero-based array no matter what ('Option Base'-related).
' If you don't do this, instead of both occurrences of '0',
' use the recommended (more accurate) 'LBound(sheetsToCopy)'.
' Declare new variables to be used in the loop.
Dim NewWorkbook As Workbook, OldWorksheet As Worksheet, i As Long
' Loop through the worksheet names in the array.
For i = 0 To UBound(sheetsToCopy)
' Reference the worksheet to be copied.
Set OldWorksheet = ThisWorkbook.Sheets(sheetsToCopy(i))
If i = 0 Then ' on the first iteration...
' Add a new workbook containing only the first copied worksheet.
OldWorksheet.Copy
' Reference this new workbook.
Set NewWorkbook = Workbooks(Workbooks.Count)
Else ' on any but the first iteration
' Copy the worksheet as the last sheet in the new workbook.
OldWorksheet.Copy After:=NewWorkbook.Sheets(NewWorkbook.Sheets.Count)
End If
Next i
' Break links in the new workbook.
NewWorkbook.BreakLink Name:=ThisWorkbook.Name, Type:=xlExcelLinks
' Retrieve the base name of the new workbook.
Dim saveName As String
saveName = ThisWorkbook.Sheets("Macros").Range("B13").Value
' Save the new workbook in the original folder.
Application.DisplayAlerts = False ' overwrite without confirmation.
NewWorkbook.SaveAs ThisWorkbook.Path & "\" & saveName
Application.DisplayAlerts = True
' Inform.
MsgBox "CPC saved.", vbInformation
ProcExit:
Exit Sub
ClearError:
' Continue error-handling routine.
MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf & Err.Description
Resume ProcExit
End Sub
Amateur Coder here.
Currently, I have this Macro linked via button. The goal is the following:
A. Once button is pressed, prompts users to select an excel workbook to Import data to, I have the following code for this part:
Sub select_file()
Dim FileSelect As FileDialog
Dim PathA As String
Set FileSelect = Application.FileDialog(msoFileDialogFilePicker)
With FileSelect
.Title = "Please Select the Doc you want to import Data to"
.AllowMultiSelect = False
.ButtonName = "Confirm"
If .Show = -1 Then
PathA = .SelectedItems(1)
Else
End
End If
End With
Workbooks.Open Filename:=PathA
End Sub
B. Once selected, begins to copy and paste data in an absolute manner/HardCoded. (I know its discouraged, but cell will not change ever) OR hard write the following formula into the destination cell. Please Assume F26 is from the destination document.
=IF(F26='[source.xlsm]Sheet1'!E10,'[Source.xlsm]Sheet1'!G10,"#REF")
How do I make Part B occur without recording it as a macro? Better yet, how do I make it plop that data into the destination?
Edit 1: The paste portion is me using the if function for verification.
If you insist on making the user identify the correct workbook/worksheet, then you can try something like this:
Sub Main_Sub()
Dim SourceWB As Workbook
Set SourceWB = ManualSelectWorkbook
' >>> Following line are only to demonstrate
' selected workbook is saved as "SourceWB"
Debug.Print SourceWB.Sheets(1).Range("A1").Value
SourceWB.Activate
End Sub
Function ManualSelectWorkbook() As Workbook
' > Variables
Dim WB As Workbook 'Possible Destination Workbook
Dim Dict As Object 'Dictionary of workbook names
Dim PromptText As String 'Inputbox Text Prompt
Dim WBselected As Integer 'Index number of selected workbook
Dim I As Integer 'Iterations
' > Variable Prep
I = 1
PromptText = ""
Set Dict = CreateObject("Scripting.Dictionary")
' > Store names of each open workbook
For Each WB In Application.Workbooks
Dict.Add I, WB.Name
PromptText = PromptText & "#" & I & " = " & WB.Name & vbCrLf
I = I + 1
Next WB
' > Ask user which workbook they wish to use
WBselected = InputBox("Please indicate which workbook you would like this data copied to:" & vbCrLf & vbCrLf & _
PromptText & vbCrLf & _
"Must be integer.", "Workbook Selection", "1")
' > Set Function = selected workbook
'Debug.Print Dict(WBselected)
Set ManualSelectWorkbook = Workbooks(Dict(WBselected))
' > Clear dictionary
Dict.RemoveAll
End Function
You can even do the exact same thing inside the selected workbook to identify the correct worksheet.
-
On the otherhand, if you know the partial name of the output workbook, you can use something like this:
Sub ExampleSub()
'Sub to initiate function
AlternateEnding.Activate
End Sub
Function AlternateEnding() As Workbook
Dim WB As Workbook
For Each WB In Application.Workbooks
If WB.Name Like "*Insert partial workbook name*" Then '<<< Must Leave asterixes.
AlternateEnding = WB
Exit Function
End If
Next WB
End Function
I've encountered a strange thing: I've joined three workbooks: Personal Data Tracker, Global Tracker and the workbook with pivots and charts. The logic is as it follows: the user clicks on a button after the work is finished so the data is copied to the GL Tracker. Once the change event is triggered in the GL Tracker Table, the last workbook opens, the pivot is refreshed upon the open vent and the wb is closed.
Everything seems to be working fine, however when I run the macro live, at the very end I get an error message about
"Application-defined or object-defined error".
Only OK and Help button displayed, it doesn't make the VBE Open so I could debug it.
Would anyone know what it may be happening even if the whole chain works fine?
Thank you.
Code from the Personal Tracker:
Sub test()
Dim path As String
Dim wb As Workbook
path = ThisWorkbook.path & "\Dest.xlsm"
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Total").Range("R1").Value = Date
Range("R1").Font.Color = VBA.ColorConstants.vbWhite
Worksheets("TOTAL").Range("B2:B13").Copy
On Error GoTo Handler
Workbooks.Open (path)
On Error GoTo 0
Set wb = Workbooks("Dest")
Worksheets("Sheet1").Range("B2").PasteSpecial Paste:=xlPasteValues
Exit Sub
Handler:
MsgBox "Someone else is saving their data at the moment." & vbNewLine & _
"Please try in a few seconds"
End Sub
Code from the GL Tracker:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MRange As Range
Dim wbPivot As Workbook
Dim pt As PivotTable
Dim ws As Worksheet
Dim Name As String
Dim answer As VbMsgBoxResult
Set MRange = ThisWorkbook.Sheets(1).Range("Table1")
Name = Application.UserName
Application.ScreenUpdating = False
If Not Intersect(Target, MRange) Is Nothing Then
Application.EnableEvents = True
Set wbPivot = Workbooks.Open("C:\Users\jakub\Desktop\Excel - various\Pivot.xlsm")
End If
'refresh
For Each ws In wbPivot.Worksheets
For Each pt In ws.PivotTables
pt.PivotCache.Refresh
pt.Update
pt.RefreshTable
Next
Next
'saving
Application.ScreenUpdating = True
If Application.UserName <> "Jakub Tracz" Then
MsgBox "User not authorised. Workbook will be closed."
wbPivot.Close True
ThisWorkbook.Close True
Else
answer = MsgBox(Prompt:="Do you want to save and close the workbook?", _
Buttons:=vbYesNo + vbQuestion)
Select Case answer
Case vbYes
wbPivot.Close True
ThisWorkbook.Close True
Case vbNo
MsgBox "Welcome, " & Application.UserName
End Select
End If
End Sub
I'm going to give you a proof of concept code as an example for you to use. This will not exactly answer your question with code you can just copy/paste, but you will be able to use this to put it together the way you want it to work instead of me making assumptions about many things and restructuring it myself.
This simply demonstrates how to use a workbook object variable in one routine that can reference another workbook, and how to make changes to that 2nd workbook and save/close it.
Sub Tracker_Update()
Dim wbPivot as Workbook
' open the workbook
Set wbPivot = Workbooks.Open("C:\Users\jakub\Desktop\Excel - various\Test.xlsx")
' optionally make it hidden
wbPivot.Visible = False
With wbPivot
' pretend this code updates the pivot table
.Worksheets(1).Range("A1") = "hello world"
' Close and save it
.Close True
End With
' optionally clear the variable
' this is not really needed in VBA, but if you eventually
' start using VB.NET with Excel as a COM object,
' you will want to know how to do this part when you are done
Set wbPivot = Nothing
End Sub
I think you will like this approach in the end much better in the end anyway, as the code isn't scattered around so much in different places. Easier to debug later, and easier for someone else to understand what you are doing if and when you leave the company.
My macro's were working perfect in excel 2010, but in 2013 I have a major problem with activating workbook in vba and than when certain sheet is selected + cell is selected I can fill in data, but when pressing enter or arrow key, the data is set to the first visible page of my file.
This happens when I activate another workbook, but also in the same workbook when I select a certain sheet, the data entered will go to the first sheet... what has changed from excel 2010 to 2013 that makes this happen??
this is the code I use:
Workbooks(MachineInspectieLijst & ".xlsm").Activate
Workbooks(MachineInspectieLijst & ".xlsm").Worksheets(MachineInspectieLijst).Range("V5").Select
When I fill in a value in V5 and enter, the value disappears and shows up on V5 in first page...mostly.
When I manually switch between the pages or workbooks, than it works... I founnd nowhere an answer.
hope somebody has the answer.
Do the process sequentially:
Sub hfjsdfh()
Workbooks(MachineInspectieLijst & ".xlsm").Activate
Worksheets(MachineInspectieLijst).Select
Range("V5").Select
End Sub
This is the actual sub, I tried your suggestion, but exactly the same...Indeed, it is like the second workbook is not really activated, but how to solve? has it to do with the userform who stays loaded? this one must stay loaded, as it contains lot of necessary information and is only unloaded at new start. Nevertheless, I tried to unload as test, but same problem. Can it be due to excel itself?
Private Sub CmdGetInspectionList_Click()
Dim thesentence As String
Dim WB As Workbook
Set WB = ThisWorkbook
Dim WB2 As Workbook
frmKlantSelectie.Hide
Application.EnableEvents = False
If Me.cboDocumentType.Value = "Sales Budget Quotation" Then
MachineInspectieLijst = "Machines_Sales"
WB.Worksheets("PreInspArticles").Range("J1") = "Sales"
Else
MachineInspectieLijst = Me.cboInspectieMachine.Value
End If
loginnaam = StrConv(WindowsUserName, vbUpperCase)
thesentence = "C:\Users\" & loginnaam & "\Dropbox\2_Doc_Service\DATA\Pre_Inspection_Checklist\" & MachineInspectieLijst & ".xlsm"
'checken ofdat de file wel bestaat in de directory
If Dir(thesentence) <> "" Then
MsgBox "Machine Check list exists! Press 'OK' and file will be shown!"
'Test to see if the file is open.
If IsFileOpen(thesentence) Then
Workbooks(MachineInspectieLijst & ".xlsm").Activate
Else
'Display a message stating the file is not in use.
Set WB2 = Workbooks.Open(thesentence)
End If
Else
MsgBox "No machine selected Or Check list not yet existing."
frmKlantSelectie.Show
Me.TxtInspectionList.SetFocus
Exit Sub
End If
WB2.Worksheets(1).Range("V5").Select
Application.EnableEvents = True
End Sub
I've solved this, tweaked the code a bit and now it works fine. I won't attempt to post the new code, as every time I try I end up with bits of code above and below the code block.
We are experiencing major problems with shared workbooks, so as a quick fix I've written some code to move a number of worksheets out of the shared workbook to individual workbooks, which each user can open exclusively.
When I move them (as described above) it removes the worksheet from the main workbook, creates a new workbook with the one (same) worksheet AND updates all formula (links become external to new workbook).
When I try to move them back, it 'copies' the worksheet back into the main workbook, but leaves the worksheet in the individual workbook, AND does NOT update the formula (in fact it appears to break them, lots of #REF after the process).
What I'd like it to do is remove the worksheet from the individual workbook, moving it back to the main workbook and update the links.
Here's my code:
Public Sub ResourceMerge()
'-- Rich Head, 5/12/2012
'-- Merges the separated resource worksheets into the main workbook (sledge hammer to fix
'-- shared workbooks issue) which has arisen since XP rollout
'Handle errors
On Error GoTo Err
'Variables
Dim wbResourceNames(1 To 20), cv, myName As String, _
ws As Worksheet, _
wb, targetwb As Workbook, _
x, i As Integer
'Before any changes made, backup the master workbook
myName = ActiveWorkbook.Name 'Get current workbook name
myName = Mid(myName, 1, Len(myName) - 4) 'Remove the .xls"
myName = myName & "_backup2_" & Format(Date, "d mmm yyyy") & ".xls" 'Add "_backup current date.xls"
ActiveWorkbook.SaveCopyAs myName 'Save a copy with the new name
Set targetwb = Application.ActiveWorkbook 'Store the main workbook
'Make the people control panel sheet active and select cell B8 (row above first name)
Set ws = Sheets("People Control Panel")
ws.Activate
ActiveSheet.Range("B8").Activate
'Loop down through the names (ignoring any Spare) to get all the resource names
x = 0
Do Until x = 20 'Assumes maximum 20 resources
x = x + 1
Debug.Print x
ActiveCell.Offset(Rowoffset:=1).Activate 'Move down one cell
If Left(ActiveCell.Value, 5) = "Spare" Then 'Ignore 'spare' rows
GoTo Loopy
End If
wbResourceNames(x) = ActiveCell.Value 'Get the resource name
Set wb = Workbooks.Open(wbResourceNames(x)) 'Open the individual resource worksheet
'Move sheet back into main workbook
wb.Sheets(1).Move _
after:=targetwb.Sheets(targetwb.Sheets("OFF SHORE"))
wb.Close 'Close new workbook
Loopy:
Loop 'Do next resource
' ActiveWorkbook.Save 'Save the reduced master
GoTo Endy 'All done
Err:
If Err = 9 Then 'Incorrect worksheet name?
MsgBox "The VBA code has trapped an error ('subscript out of range'), this is likely to be " & _
"because a resource name from the 'People Control Panel' (a hidden worksheet) does not " & _
"match the name of the worksheet; please delete this spreadsheet and any individual " & _
"spreadsheets created and start again (change the name of the backup sheet created - by " & _
"removing the '_backup2 and date' from the filename, correct the worksheet name error, save " & _
"the workbook and run the macro again)."
GoTo Endy
End If
MsgBox "Oops... VBA code error, number: " & Err & ", with a description of: " & Error(Err)
Endy:
End Sub