Programmatically add workbook event and save it - vba

I have a list of excel files in a spreadsheet. I'd like to loop through them and add a worksheet event to each. Save it, close it and move on to the next. The problem is that when I reopen (manually) the workbook the code is gone.
Inside the for each loop:
Set xl = Workbooks.Open(filepath)
addCode xl 'subroutine to add code
xl.Save
xl.Close SaveChanges:=False
The addCode subroutine is:
Sub addCode(book As Excel.Workbook)
acsh = book.ActiveSheet.CodeName
startline = book.VBProject.VBComponents(acsh).CodeModule.CreateEventProc("SelectionChange", "Worksheet") + 1
book.VBProject.VBComponents(acsh).CodeModule.InsertLines startline, codetoadd
End Sub
If I comment out xl.Close the code is in the workbook and works. I can manually save and close the file and the code remains. I've added a break point between xl.save and xl.close and made a copy of the file. After the code is done neither has the changes. I've tried using xl.saveas and xl.close SaveChanges:=True. All have identical results.
I'm using Excel 2013, I've told excel to trust access to the VBA object model. I've tried using XLS files and XLSM files. Obviously XLSX won't work.

Here is some sample code which is working for me on Excel 2010. The changes I made to your example code are:
use a .xlsm for the target workbook - I know you said you already did that.
reference a specific worksheet in the AddCode sub rather than pick up the sheet name from ActiveSheet.
set the workbook dirty status per Ralph's comment
Don't set the SaveChanges flag when closing the target workbook
Other than that, my version is pretty similar to yours. I think it is the wb.Saved = False line that does the trick i.e. the dirty flag. I tried to use the SaveAs method on the VBProject itself thinking it would be the same as hitting the save button when you are in the VBA Editor itself. However, this just gives unhelpful errors.
Here's the sample code:
Option Explicit
Sub Test()
Dim wbTarget As Workbook
Dim strCode As String
' get target workbook
Set wbTarget = Workbooks.Open("\\server\path\Book3.xlsm")
' test setting code to worksheet change
strCode = "Debug.Print ""Sheet selection changed to: "" & Target.Address"
AddWorksheetChangeCode wbTarget, "Sheet1", strCode
' test saving the target workbook
With wbTarget
' set book to dirty to force the save
.Saved = False
.Save
.Close
End With
End Sub
Sub AddWorksheetChangeCode(ByRef wb As Workbook, strWorksheetName As String, strCode As String)
Dim intInsertLine As Integer
' create stub for event and get line to insert
intInsertLine = wb.VBProject.VBComponents(strWorksheetName).CodeModule.CreateEventProc("SelectionChange", "Worksheet") + 1
' add event logic
wb.VBProject.VBComponents(strWorksheetName).CodeModule.InsertLines intInsertLine, strCode
End Sub

Related

VBA to automatically replace Modules in several workbooks

Someone posted a question on mrexcel, asking how to replace modules in existing workbooks with new ones:
https://www.mrexcel.com/forum/excel-questions/760732-vba-automatically-replace-modules-several-workbooks.html
They answered their question with others support as follows:
Sub Update_Workbooks()
'This macro requires that a reference to Microsoft Scripting Routine
'be selected under Tools\References in order for it to work.
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fso As New FileSystemObject
Dim source As Scripting.Folder
Dim wbFile As Scripting.File
Dim book As Excel.Workbook
Dim sheet As Excel.Worksheet
Dim Filename As String
Dim ModuleFile As String
Dim Element As Object
Set source = fso.GetFolder("C:\Users\Desktop\Testing") 'we will know this since all of the files will be in one folder
For Each wbFile In source.Files
If fso.GetExtensionName(wbFile.Name) = "xlsm" Then 'we will konw this too. All files will be .xlsm
Set book = Workbooks.Open(wbFile.path)
Filename = FileNameOnly(wbFile.Name)
'This will remove all modules including ClassModules and UserForms.
'It will keep all object modules like (sheets, ThisWorkbook)
On Error Resume Next
For Each Element In ActiveWorkbook.VBProject.VBComponents
ActiveWorkbook.VBProject.VBComponents.Remove Element
Next
On Error GoTo ErrHandle
' Export Module1 from updating workbook
ModuleFile = Application.DefaultFilePath & "\tempmodxxx.bas"
Workbooks("Update Multiple Workbooks.xlsm").VBProject.VBComponents("Module1") _
.Export ModuleFile
' Replace Module1 in Userbook
Set VBP = Workbooks(Filename).VBProject
On Error Resume Next
With VBP.VBComponents
.Import ModuleFile
End With
' Delete the temporary module file
Kill ModuleFile
book.Close True
End If
Next
Exit Sub
ErrHandle:
' Did an error occur?
MsgBox "ERROR. The module may not have been replaced.", _
vbCritical
End Sub
However, its quite large, and wanted to show a simple way of doing the same thing. Also, I found that when Importing the Modules to a different sheet, the ThisWorkBook and Sheet files are also imported as ClassModules. This is not always desired, so see answer below for alternative options!
You can import (or export if you flip the order) Modules from a different sheet using the following Sub:
Sub import_mods()
'First define each module you're looking to
'take from the excel sheet "Workbook_with_Modules.xlsm"
For Each Element In Workbooks("Workbook_with_Modules.xlsm").VBProject.VBComponents
'MsgBox Element.Name 'I ran this first to see which modules are available
'First, export each module from the "Workbook_with_Modules.xlsm"
Workbooks("Workbook_with_Modules.xlsm").VBProject.VBComponents(Element.Name).Export (Element.Name)
'Then, Import them into the current Workbook
Workbooks(ThisWorkbook.Name).VBProject.VBComponents.Import (Element.Name)
Next Element
End Sub
I created a separate sub to delete the one's I'm not interested in keeping. You can Call it directly from the previous sub if you prefer, or build the If statement for the type into the previous sub as well, but for this example's sake, its a separate Sub entirely.
Sub rems()
'Types:
' 100 = Sheets and ThisWorkbook for current Workbook
' 1 = Modules (such as "Module1")
' 2 = ClassModules (such as other sheets from a different Workbook "ThisWorkBook1")
For Each Element In Workbooks(ThisWorkbook.Name).VBProject.VBComponents
'I first tested the types and corresponding number
'MsgBox Workbooks(ThisWorkbook.Name).VBProject.VBComponents(Element.Name).Type
'Now, the If function for removing all ClassModules (Type = 2)
If Workbooks(ThisWorkbook.Name).VBProject.VBComponents(Element.Name).Type = 2 Then
Workbooks(ThisWorkbook.Name).VBProject.VBComponents.Remove Element
End If
Next Element
End Sub
Hope this helps anyone!
I have a problem importing the modules, they are imported adding a 1 at the end of the name.
I tried to delete them before, and then import all, but the deletion is not executed until the sub ends.

Using Workbooks object with absolute address while the workbook is not opened [duplicate]

I want to search through existing Excel files with a macro, but I don't want to display those files when they're opened by the code. Is there a way to have them open "in the background", so to speak?
Not sure if you can open them invisibly in the current excel instance
You can open a new instance of excel though, hide it and then open the workbooks
Dim app as New Excel.Application
app.Visible = False 'Visible is False by default, so this isn't necessary
Dim book As Excel.Workbook
Set book = app.Workbooks.Add(fileName)
'
' Do what you have to do
'
book.Close SaveChanges:=False
app.Quit
Set app = Nothing
As others have posted, make sure you clean up after you are finished with any opened workbooks
If that suits your needs, I would simply use
Application.ScreenUpdating = False
with the added benefit of accelerating your code, instead of slowing it down by using a second instance of Excel.
To open a workbook as hidden in the existing instance of Excel, use following:
Application.ScreenUpdating = False
Workbooks.Open Filename:=FilePath, UpdateLinks:=True, ReadOnly:=True
ActiveWindow.Visible = False
ThisWorkbook.Activate
Application.ScreenUpdating = True
Using ADO (AnonJr already explained) and utilizing SQL is possibly the best option for fetching data from a closed workbook without opening that in conventional way. Please watch this VIDEO.
OTHERWISE, possibly GetObject(<filename with path>) is the most CONCISE way. Worksheets remain invisible, however will appear in project explorer window in VBE just like any other workbook opened in conventional ways.
Dim wb As Workbook
Set wb = GetObject("C:\MyData.xlsx") 'Worksheets will remain invisible, no new window appears in the screen
' your codes here
wb.Close SaveChanges:=False
If you want to read a particular sheet, need not even define a Workbook variable
Dim sh As Worksheet
Set sh = GetObject("C:\MyData.xlsx").Worksheets("MySheet")
' your codes here
sh.Parent.Close SaveChanges:=False 'Closes the associated workbook
Even though you've got your answer, for those that find this question, it is also possible to open an Excel spreadsheet as a JET data store. Borrowing the connection string from a project I've used it on, it will look kinda like this:
strExcelConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & objFile.Path & ";Extended Properties=""Excel 8.0;HDR=Yes"""
strSQL = "SELECT * FROM [RegistrationList$] ORDER BY DateToRegister DESC"
Note that "RegistrationList" is the name of the tab in the workbook. There are a few tutorials floating around on the web with the particulars of what you can and can't do accessing a sheet this way.
Just thought I'd add. :)
A much simpler approach that doesn't involve manipulating active windows:
Dim wb As Workbook
Set wb = Workbooks.Open("workbook.xlsx")
wb.Windows(1).Visible = False
From what I can tell the Windows index on the workbook should always be 1. If anyone knows of any race conditions that would make this untrue please let me know.
The problem with both iDevlop's and Ashok's answers is that the fundamental problem is an Excel design flaw (apparently) in which the Open method fails to respect the Application.ScreenUpdating setting of False. Consequently, setting it to False is of no benefit to this problem.
If Patrick McDonald's solution is too burdensome due to the overhead of starting a second instance of Excel, then the best solution I've found is to minimize the time that the opened workbook is visible by re-activating the original window as quickly as possible:
Dim TempWkBk As Workbook
Dim CurrentWin As Window
Set CurrentWin = ActiveWindow
Set TempWkBk = Workbooks.Open(SomeFilePath)
CurrentWin.Activate 'Allows only a VERY brief flash of the opened workbook
TempWkBk.Windows(1).Visible = False 'Only necessary if you also need to prevent
'the user from manually accessing the opened
'workbook before it is closed.
'Operate on the new workbook, which is not visible to the user, then close it...
Open the workbook as hidden and then set it as "saved" so that users are not prompted when they close out.
Dim w As Workbooks
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Set w = Workbooks
w.Open Filename:="\\server\PriceList.xlsx", UpdateLinks:=False, ReadOnly:=True 'this is the data file were going to be opening
ActiveWindow.Visible = False
ThisWorkbook.Activate
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
w.Item(2).Saved = True 'this will suppress the safe prompt for the data file only
End Sub
This is somewhat derivative of the answer posted by Ashok.
By doing it this way though you will not get prompted to save changes back to the Excel file your reading from. This is great if the Excel file your reading from is intended as a data source for validation. For example if the workbook contains product names and price data it can be hidden and you can show an Excel file that represents an invoice with drop downs for product that validates from that price list.
You can then store the price list on a shared location on a network somewhere and make it read-only.
Open them from a new instance of Excel.
Sub Test()
Dim xl As Excel.Application
Set xl = CreateObject("Excel.Application")
Dim w As Workbook
Set w = xl.Workbooks.Add()
MsgBox "Not visible yet..."
xl.Visible = True
w.Close False
Set xl = Nothing
End Sub
You need to remember to clean up after you're done.
In excel, hide the workbooks, and save them as hidden. When your app loads them they will not be shown.
Edit: upon re-reading, it became clear that these workbooks are not part of your application. Such a solution would be inappropriate for user workbooks.

Open another workbook with vba that contains all the macros

Instead of having all the macro's stored in each workbook, we would like to have them stored in one global one. We tried using Personal.xlsb file, however every time excel crashes or system administrator forced restart with excel open it created personal.v.01 ....v.100 files, and they interfered with each other, got corrupted etc.. So instead we are trying to add a small macro to each excel workbook we make which then should open a global excel workbook with all the macros, however it does not open it(normal.xlsb), where is the problem? If I manually run it it works fine, it just does not autorun..
Option Explicit
Public Sub Workbook_Open()
Dim sFullName As String
Dim xlApp As Excel.Application
Dim wbReturn As Workbook
sFullName = "Z:\Dokumentstyring\normal.xlsb"
Set xlApp = GetObject(, "Excel.Application") 'need to do so to open it in same instance otherwise the global macros can not be called.
Set wbReturn = xlApp.Workbooks.Open(filename:=sFullName, ReadOnly:=True)
If wbReturn Is Nothing Then
MsgBox "Failed to open workbook, maybe z drive is down?"
Else
ThisWorkbook.Activate'Dont know how to pass object to modules, so instead activate it and in createbutton set wb= activeworkbook..
Application.Run ("normal.xlsb!CreateButtons")
End If
End Sub
Public Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wb As Workbook
For Each wb In Application.Workbooks
If InStr(UCase(wb.Name), "PARTSLIST") > 0 And wb.Name <> ThisWorkbook.Name Then Exit Sub
Next wb
On Error Resume Next
Workbooks("normal.xlsb").Close
Workbooks("filter.xlsx").Close
End Sub
You create your addin, as just an empty workbook, holding nothing but the code
Like this
Then you add a reference to it, in the workbook that you wish to use, in VBA, like this. My Documents, is a folder on a network drive, not "my documents" local.
And then you can call like so.
So based on input from #Nathan_Sav and #Ralph I have come to a partly good solution:
I have called my addinn Normal and saved this on Z:Dokumenstyring\Normal.xlam
I then removed all the code in Thisworkbook of Normal:
Private Sub Workbook_Open()
Dim ExcelArgs As String
Dim arg As String
ExcelArgs = Environ("ExcelArgs")
'Call deleteMacros.deletePersonalFiles
'MsgBox ExcelArgs
If InStr(UCase(ExcelArgs), "CREO,") > 0 Then
Application.DisplayAlerts = False
If Len(ExcelArgs) > Len("CREO,") Then
arg = Split(ExcelArgs, ",")(1)
Call Creo.addNewPartToPartslist(arg)
End If
Application.DisplayAlerts = True
End If
If InStr(UCase(ExcelArgs), "DOKLIST,") > 0 Then
Application.DisplayAlerts = False
If Len(ExcelArgs) > Len("DOKLIST,") Then
arg = Split(ExcelArgs, ",")(1)
Call ProsjektListen.dbDumpDocOut(arg)
End If
Application.DisplayAlerts = True
End If
and put this in a new workbook called Z:Dokumenstyring\Creo.xlsm
I have so edited all my bat files(which previously were using personal.xlsb):
echo "Launch excel"
Set ExcelArgs=CREO,ADDPART
"C:\Program Files (x86)\Microsoft Office\OFFICE16\Excel.exe" /x /r "z:\Dokumentstyring\Creo.xlsm"
So when I run the bat file it adds a parameter to enviroment, start creo.xlsm, which then starts the addin which launch my userform.
So if I now want to update the look of that that userform I do this by modifying the Z:Dokumenstyring\NormalDebug.xlam, then i save a copy which i write over Z:Dokumenstyring\Normal.xlam and I also told every user to not copy the addin to the default location in excel but keep it in Z:Dokumenstyring\Normal.xlam.
My shapes in my excel sheets seems to work with just the macro name in the procedure, however there might be an conflict if two procedures have the same name, but located in different procedures. So I also altered this to
ws1.Shapes(tempName).OnAction = "Normal.xlam!Custom_Button_Click"
However every click starts a new instance of the addin, how to avoid this?

Setting Document Properties while saving individual sheets

I'm not familiar with VBA at all so this has me stumped, hoping someone can help.
I have a template on a sharepoint server that is working correctly. In order to save the xlsm file with the server document properties, I have a command button which runs the following:
Sub UpdateDB()
For Each Prop In ThisWorkbook.ContentTypeProperties
If Prop.Name = "Name" Then
Prop.Value = Range("B8").Value
End If
Next Prop
Filename = Range("B59").Value
ActiveWorkbook.SaveAs Filename:=Filename, FileFormat:=52
End Sub
This is working well.
I now have another template which I want to do a similar thing but there are some complications:
I have several worksheets which I would like saved as individual files containing only the said worksheet.
The document properties for each file should different, based on a cell in each worksheet.
Now I have managed to setup point 1 and it's working OK using the following code:
Sub NewSub()
Worksheets("EMP1").Activate
Filename = Range("B1").Value
Dim wb as Workbook
Application.ActiveSheet.Copy
Set wb = ActiveWorkbook
With wb
.SaveAs Filename:=Filename, FileFormat:=52
End With
End Sub
This is working well but if I try adding in code to set the Document Properties, it doesn't work, it won't carry them through to the new file. I have tried adding the code which sets the document properties after line 2 and I have tried adding it also after line 7; it doesn't throw an error but it doesn't set any document properties either. Any help on this would be much appreciated. Thanks.

Call Macro from Hyperlink using multiple workbooks without re-opening Macro Sheet

I have 2 Workbooks:
Workbook With Macros
Workbook to write to.
I have 2 subs. One is to insert a hyperlink in the 'workbook to write to' and the other Sub will execute when the hyperlink is clicked.
However, my sub to create the Hyperlink is causing me some confusion. I need to reference the worksheet in the Macro Enabled Workbook, but doing that requires a Workbook.Open command. Obviously the Macro Enabled Workbook will already be open so this closes and re-opens it. I've gotten very muddled with this, can someone point me in the right direction?
So Macro Sheet will have the below Sub, the link is to another Sub in the same sheet. "CreateHyperlinks" is called from another method which writes to an external spreadsheet.
Obviously "ActiveSheet" below is wrong. I want to write to a different spreadsheet, so I will need to open it also (I assume)?
Or, can I pass the worksheet that is being written to from it's write method which is calling "CreateHyperlinks" or am I coupling everything too much as it is?
' This is called elsewhere
Sub CreateHpyerlinks(rangeValue, textValue)
Dim fileName As String
Dim wb As Workbook
Dim TheSheet As Worksheet
fileName = "c:\blah\blah.xlsm"
' ** This is the part: How do i reference "TheSheet" without opening the XL?
Set wb = Workbooks.Open(fileName:=fileName)
Set TheSheet = wb.Sheets("MasterCard")
TheSheet.UsedRange.Select
ActiveSheet.Hyperlinks.Add Anchor:=rangeValue, Address:=TheSheet!THISISMYMACROHERE(textValue), SubAddress:="", ScreenTip:="Go to Word Documebnt", TextToDisplay:=textValue
End Sub
UPDATED:
I have updated the Sub, and am hitting Object does not support his method or property
Sub CreateHpyerlinks(rangeValue, textValue)
Dim fileName As String
Dim wb As Workbook
Dim wbWrite As Workbook
Dim TheSheetWithMacros As Worksheet
Dim TheSheetToWriteTo As Worksheet
fileName = "c:\WorkbookToWriteTo.xlsx"
Set wb = Application.Workbooks(ThisWorkbook.Name)
Set TheSheetWithMacros = wb.Worksheets("Sheet1")
Set wbWrite = Workbooks.Open(fileName:=fileName)
Set TheSheetToWriteTo = wbWrite.Worksheets("Sheet1")
' This Line Errors:
TheSheetToWriteTo.Hyperlinks.Add Anchor:=rangeValue, Address:="", SubAddress:=TheSheetWithMacros!Goto80BytePopulationGuide(textValue), ScreenTip:="Call Macro", TextToDisplay:=textValue
wbWrite.Save
wbWrite.Close
End Sub
The line TheSheetToWriteTo.Hyperlinks.Add Anchor:=rangeValue, Address:="", SubAddress:=TheSheetWithMacros!Goto80BytePopulationGuide(textValue), ScreenTip:="Call Macro", TextToDisplay:=textValue is at fault, clearly TheSheetWithMacors!CallMacro doesn't work like I had hoped.
You may be able to copy the Module's code from one workbook to the other workbook. I assume for now that the Worksheet module only contains the macro and nothing else (or that it is OK to copy everything in that module).
So the reason I propose this, is that if you can copy it, then you can point the hyperlink to a local (within the same file) macro -- because we're copying the module to the new file -- which I think you have already been able to do.
This requires you to check the trust center setting to allow access to the VBProject. A prompt will ask you to do that before it can proceed.
Sub writeit()
'copies a specified code module from one workbook, to
' a code module in another workbook
'
'ASSUMPTIONS:
'-the specified destination must already exist
'-the specified destination does not already contain
' any procedures that would conflict naming with the
' copied module procedures
MsgBox "Please make sure to enable access to ""Trust access to the VBA Project Object Model""", vbInformation
Application.CommandBars.ExecuteMso("MacroSecurity")
Dim macrobook As Workbook
Dim otherbook As Workbook
Dim lines As String
Dim destModule As Object 'VBComponent
Dim copyModule As Object 'VBComponent
Set macrobook = ThisWorkbook 'Modify as needed
Set copyModule = macrobook.VBProject.VBComponents("Sheet1") 'Name of your module to copy
Set otherbook = Workbooks(2) 'Modify as needed
Set destModule = otherbook.VBProject.VBComponents("Sheet1") 'name of where it will go
'Appends the lines from CopyModule to DestModule
With destModule.CodeModule
.InsertLines .CountOfLines + 1, copyModule.CodeModule.lines(1, copyModule.CodeModule.CountOfLines)
End With
End Sub