The code i have works, but not as good as i hoped. I have an .xlam file that i have 2 user forms in. I activate them from the XRibbon with this code.
Option Explicit
' Fylla på info i excel filer
Sub StartAnlaggningInformation(control As IRibbonControl)
Dim blnRun As VbMsgBoxResult
Call SafetyCatch("Anläggnings Information", blnRun)
If blnRun = vbNo Then Exit Sub
Application.ScreenUpdating = False
Call frmProjektInfo.Show
End Sub
' Fylla på info i Schrack beställningsmall
Sub BestSchrackMaterial(control As IRibbonControl)
Dim blnRun As VbMsgBoxResult
Call SafetyCatch("Beställa Scrack-seconet material.", blnRun)
If blnRun = vbNo Then Exit Sub
If ActiveSheet.Name = "Basuppgifter projekt" Then
Call ValjBestall.Show
Else
MsgBox "Välj rätt flik i Schrack's beställningsmall"
End If
End Sub
The problem i have is with the handling of the workbook that is active when i click the button on the ribbon. The code kind of do what i want it to, but i have a feeling that there's a better way to do this that doesn't force the user to only have one excel file open for the code to work:
Private Sub UserForm_Activate()
Application.ScreenUpdating = False
' Run the initialization code here
InitializeForm
' Other code for activation if needed
End Sub
Private Sub InitializeForm()
' Populate cbxObjektsnamn with values from column A in DataFile.xlsm
Dim wsData As Worksheet
Dim lastRow As Long
Dim objektsnamnRange As Range
Dim cell As Range
Dim headers As Variant
Dim dataFileName As String
Application.ScreenUpdating = False
' Get the path to the user's AppData folder
Dim appDataPath As String
appDataPath = Environ("APPDATA")
' Set the path to your data Excel file
dataFileName = appDataPath & "\Microsoft\AddIns\DataFile.xlsm"
' Check if the file exists
If Dir(dataFileName) = "" Then
' If the file doesn't exist, create it with headers
Set wsData = Workbooks.Add.Sheets(1)
headers = Array("Objektsnamn", "Anläggningsnummer", "Projektnummer", "ProjektledareNamn", "ProjektledareTel", _
"DelegeradNamn", "DelegeradTel", "TeknikerNamn", "TeknikerTel", "SBF110", _
"Anläggningsägare", "ÄgarAdress", "ÄgarPostnr", "ÄgarPostort", "ObjektAdress", _
"ObjektPostort", "ObjektPostnr", "Nyttjare", "AnlSkötare1namn", "AnlSkötare1telefon", _
"AnlSkötare2namn", "AnlSkötare2telefon", "LedandeMontörNamn", "LedandeMontörTelefon", _
"LevAdress", "LevPostort", "LevPostnr", "LastUsed")
' Write headers to the first row
wsData.Range("A1").Resize(1, UBound(headers) + 1).Value = headers
' Save the workbook as xlsm
wsData.Parent.SaveAs dataFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
' If the file exists, open it
Workbooks.Open dataFileName
Set wsData = Workbooks("DataFile.xlsm").Sheets(1)
End If
' Assuming DataFile.xlsm is already open
On Error Resume Next
Set wsData = Workbooks("DataFile.xlsm").Sheets(1)
On Error GoTo 0
If Not wsData Is Nothing Then
' Find the last row in column A with data
lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
Dim lastUsedRow As Long
lastUsedRow = wsData.Range("AB:AB").Find(What:="X", LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=True).Row
If lastRow >= 2 Then ' Check if there is data in the workbook
' Set the range for cbxObjektsnamn
Set objektsnamnRange = wsData.Range("A2:A" & lastRow)
' Clear the existing items in the ComboBox
Me.cbxObjektsnamn.Clear
' Loop through the range and add each item to the ComboBox
For Each cell In objektsnamnRange
Me.cbxObjektsnamn.AddItem cell.Value
Next cell
If lastUsedRow >= 2 Then
Me.cbxObjektsnamn.Text = Me.cbxObjektsnamn.List(lastUsedRow - 2)
End If
Else
' Handle the case when there is no data in DataFile.xlsm
MsgBox "Ingen data hittad i fil DataFile.xlsm.", vbExclamation
End If
Else
' Handle the case when DataFile.xlsm is not open
MsgBox "DataFile.xlsm är inte öppen.", vbExclamation
End If
End Sub
Private Sub cmbCancel_Click()
' Close the user form without saving any changes
Unload Me
' Close DataFile.xlsm
Application.ScreenUpdating = True
On Error Resume Next
Workbooks("DataFile.xlsm").Close SaveChanges:=False
On Error GoTo 0
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
' Close DataFile.xlsm
Workbooks("DataFile.xlsm").Close SaveChanges:=False
End If
Application.ScreenUpdating = True
End Sub
Private Sub cbxObjektsnamn_Change()
' Disable the Change event to prevent recursion
Application.EnableEvents = False
Application.ScreenUpdating = False
' Get the selected value from cbxObjektsnamn
Dim selectedValue As String
selectedValue = CStr(Me.cbxObjektsnamn.Value)
' Find the corresponding row in DataFile.xlsm based on the selected value
Dim wsData As Worksheet
Set wsData = Workbooks("DataFile.xlsm").Sheets(1)
' Assuming the data is in columns B to Z (adjust as needed)
Dim dataRange As Range
Set dataRange = wsData.Range("A:AA")
' Find the row that corresponds to the selected value
Dim selectedRow As Variant
selectedRow = Application.Match(selectedValue, dataRange.Columns(1), 0)
If Not IsError(selectedRow) Then ' Check if a match is found
' Update other textboxes with information from the selected row
Me.tbxAnlaggningsnummer.Value = dataRange.Cells(selectedRow, 2).Value
Me.tbxProjektnummer.Value = dataRange.Cells(selectedRow, 3).Value
Me.tbxProjektledareNamn.Value = dataRange.Cells(selectedRow, 4).Value
Me.tbxProjektledareTel.Value = dataRange.Cells(selectedRow, 5).Value
Me.tbxDelegeradNamn.Value = dataRange.Cells(selectedRow, 6).Value
Me.tbxDelegeradTel.Value = dataRange.Cells(selectedRow, 7).Value
Me.tbxTeknikerNamn.Value = dataRange.Cells(selectedRow, 8).Value
Me.tbxTeknikerTel.Value = dataRange.Cells(selectedRow, 9).Value
Me.tbxSBF110.Value = dataRange.Cells(selectedRow, 10).Value
Me.tbxAnlaggningsagare.Value = dataRange.Cells(selectedRow, 11).Value
Me.tbxAgarAdress.Value = dataRange.Cells(selectedRow, 12).Value
Me.tbxAgarPostnr.Value = dataRange.Cells(selectedRow, 13).Value
Me.tbxAgarPostort.Value = dataRange.Cells(selectedRow, 14).Value
Me.tbxObjektAdress.Value = dataRange.Cells(selectedRow, 15).Value
Me.tbxObjektPostort.Value = dataRange.Cells(selectedRow, 16).Value
Me.tbxObjektPostnr.Value = dataRange.Cells(selectedRow, 17).Value
Me.tbxNyttjare.Value = dataRange.Cells(selectedRow, 18).Value
Me.tbxAnlSkotare1namn.Value = dataRange.Cells(selectedRow, 19).Value
Me.tbxAnlSkotare1telefon.Value = dataRange.Cells(selectedRow, 20).Value
Me.tbxAnlSkotare2namn.Value = dataRange.Cells(selectedRow, 21).Value
Me.tbxAnlSkotare2telefon.Value = dataRange.Cells(selectedRow, 22).Value
Me.tbxLedandeMontorNamn.Value = dataRange.Cells(selectedRow, 23).Value
Me.tbxLedandeMontorTelefon.Value = dataRange.Cells(selectedRow, 24).Value
Me.tbxLevAdress.Value = dataRange.Cells(selectedRow, 25).Value
Me.tbxLevPostort.Value = dataRange.Cells(selectedRow, 26).Value
Me.tbxLevPostnr.Value = dataRange.Cells(selectedRow, 27).Value
Else
' Handle the case when no match is found
'MsgBox "No matching data found for " & selectedValue, vbExclamation
End If
' Re-enable the Change event
Application.EnableEvents = True
End Sub
Sub UpdateOrAddData()
' Get the values from the textboxes on frmProjektInfo
Dim objektsnamn As String
Dim Anlaggningsnummer As String
Dim Projektnummer As String
Dim ProjektledareNamn As String
Dim ProjektledareTel As String
Dim DelegeradNamn As String
Dim DelegeradTel As String
Dim TeknikerNamn As String
Dim TeknikerTel As String
Dim SBF110 As String
Dim Anlaggningsagare As String
Dim AgarAdress As String
Dim AgarPostnr As String
Dim AgarPostort As String
Dim ObjektAdress As String
Dim ObjektPostor As String
Dim ObjektPostnr As String
Dim Nyttjare As String
Dim AnlSkotare1namn As String
Dim AnlSkotare1telefon As String
Dim AnlSkotare2namn As String
Dim AnlSkotare2telefon As String
Dim LedandeMontorNamn As String
Dim LedandeMontorTelefon As String
Dim LevAdress As String
Dim LevPostort As String
Dim LevPostnr As String
' Add more variables for other textboxes as needed
objektsnamn = Me.cbxObjektsnamn.Value
Anlaggningsnummer = Me.tbxAnlaggningsnummer.Value
Projektnummer = Me.tbxProjektnummer.Value
ProjektledareNamn = Me.tbxProjektledareNamn.Value
ProjektledareTel = Me.tbxProjektledareTel.Value
DelegeradNamn = Me.tbxDelegeradNamn.Value
DelegeradTel = Me.tbxDelegeradTel.Value
TeknikerNamn = Me.tbxTeknikerNamn.Value
TeknikerTel = Me.tbxTeknikerTel.Value
SBF110 = Me.tbxSBF110.Value
Anlaggningsagare = Me.tbxAnlaggningsagare.Value
AgarAdress = Me.tbxAgarAdress.Value
AgarPostnr = Me.tbxAgarPostnr.Value
AgarPostort = Me.tbxAgarPostort.Value
ObjektAdress = Me.tbxObjektAdress.Value
ObjektPostor = Me.tbxObjektPostort.Value
ObjektPostnr = Me.tbxObjektPostnr.Value
Nyttjare = Me.tbxNyttjare.Value
AnlSkotare1namn = Me.tbxAnlSkotare1namn.Value
AnlSkotare1telefon = Me.tbxAnlSkotare1telefon.Value
AnlSkotare2namn = Me.tbxAnlSkotare2namn.Value
AnlSkotare2telefon = Me.tbxAnlSkotare2telefon.Value
LedandeMontorNamn = Me.tbxLedandeMontorNamn.Value
LedandeMontorTelefon = Me.tbxLedandeMontorTelefon.Value
LevAdress = Me.tbxLevAdress.Value
LevPostort = Me.tbxLevPostort.Value
LevPostnr = Me.tbxLevPostnr.Value
' Assign values for other variables as needed
' Find the corresponding row in DataFile.xlsm based on the objektsnamn value
Dim wsData As Worksheet
Set wsData = Workbooks("DataFile.xlsm").Sheets(1)
wsData.Range("AB2:AB" & wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row).Value = ""
' Find or add the row
Dim targetRow As Long
targetRow = FindOrAddRow(wsData, objektsnamn)
' Update values in the found or added row
wsData.Cells(targetRow, 1).Value = objektsnamn
wsData.Cells(targetRow, 2).Value = Anlaggningsnummer
wsData.Cells(targetRow, 3).Value = Projektnummer
wsData.Cells(targetRow, 4).Value = ProjektledareNamn
wsData.Cells(targetRow, 5).Value = ProjektledareTel
wsData.Cells(targetRow, 6).Value = DelegeradNamn
wsData.Cells(targetRow, 7).Value = DelegeradTel
wsData.Cells(targetRow, 8).Value = TeknikerNamn
wsData.Cells(targetRow, 9).Value = TeknikerTel
wsData.Cells(targetRow, 10).Value = SBF110
wsData.Cells(targetRow, 11).Value = Anlaggningsagare
wsData.Cells(targetRow, 12).Value = AgarAdress
wsData.Cells(targetRow, 13).Value = AgarPostnr
wsData.Cells(targetRow, 14).Value = AgarPostort
wsData.Cells(targetRow, 15).Value = ObjektAdress
wsData.Cells(targetRow, 16).Value = ObjektPostor
wsData.Cells(targetRow, 17).Value = ObjektPostnr
wsData.Cells(targetRow, 18).Value = Nyttjare
wsData.Cells(targetRow, 19).Value = AnlSkotare1namn
wsData.Cells(targetRow, 20).Value = AnlSkotare1telefon
wsData.Cells(targetRow, 21).Value = AnlSkotare2namn
wsData.Cells(targetRow, 22).Value = AnlSkotare2telefon
wsData.Cells(targetRow, 23).Value = LedandeMontorNamn
wsData.Cells(targetRow, 24).Value = LedandeMontorTelefon
wsData.Cells(targetRow, 25).Value = LevAdress
wsData.Cells(targetRow, 26).Value = LevPostort
wsData.Cells(targetRow, 27).Value = LevPostnr
wsData.Cells(targetRow, 28).Value = "X"
' Update other columns as needed
On Error Resume Next
' Save the changes to DataFile.xlsm
Workbooks("DataFile.xlsm").Save
If Err.Number <> 0 Then
MsgBox "Error vid sparande av DataFile.xlsm: " & Err.Description, vbExclamation
End If
On Error Resume Next ' Reset the error handler
End Sub
Private Sub cmbUpDate_Click()
Dim customRibbonWorkbook As Workbook
Set customRibbonWorkbook = Workbooks("CustomRibbon.xlam")
' Loop through all open workbooks to find the one that is not "CustomRibbon.xlam" or "DataFile.xlsm"
Dim targetWorkbook As Workbook
For Each targetWorkbook In Workbooks
If targetWorkbook.Name <> "CustomRibbon.xlam" And targetWorkbook.Name <> "DataFile.xlsm" Then
Exit For
End If
Next targetWorkbook
' Check if a suitable workbook is found
If targetWorkbook Is Nothing Then
' Inform the user that no suitable workbook is found
MsgBox "Ingen lämplig arbetsbok hittades.", vbExclamation
Exit Sub
End If
' Call the procedure to update or add data
Application.ScreenUpdating = False
UpdateOrAddData
InitializeForm
targetWorkbook.Activate
End Sub
Function FindOrAddRow(wsData As Worksheet, objektsnamn As String) As Long
' Assuming the data is in columns A to Z (adjust as needed)
Dim dataRange As Range
Set dataRange = wsData.Range("A:AA")
' Find the row that corresponds to the objektsnamn value
Dim targetRow As Variant
targetRow = Application.Match(objektsnamn, dataRange.Columns(1), 0)
If Not IsError(targetRow) Then ' Check if a match is found
' If a match is found, return the matching row
FindOrAddRow = CLng(targetRow)
Else
' If no match is found, find the last empty row in column A
FindOrAddRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row + 1
End If
End Function
Private Sub cmbOK_Click()
' Call the procedure to update or add data
UpdateOrAddData
' Fill named cells in the active workbook
FillNamedCells
' Close the user form
Unload Me
On Error Resume Next
Workbooks("DataFile.xlsm").Close SaveChanges:=False
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Sub FillNamedCells()
' Get the workbook where the VBA code is running (ThisWorkbook)
Dim customRibbonWorkbook As Workbook
Set customRibbonWorkbook = Workbooks("CustomRibbon.xlam")
' Loop through all open workbooks to find the one that is not "CustomRibbon.xlam" or "DataFile.xlsm"
Dim targetWorkbook As Workbook
For Each targetWorkbook In Workbooks
If targetWorkbook.Name <> "CustomRibbon.xlam" And targetWorkbook.Name <> "DataFile.xlsm" Then
Exit For
End If
Next targetWorkbook
' Check if a suitable workbook is found
If targetWorkbook Is Nothing Then
' Inform the user that no suitable workbook is found
MsgBox "Ingen lämplig arbetsbok hittades.", vbExclamation
Exit Sub
End If
' Use the values from the user form to fill named cells
On Error Resume Next
targetWorkbook.Names("Objektsnamn").RefersToRange.Value = Me.cbxObjektsnamn.Value
targetWorkbook.Names("Anlaggningsnummer").RefersToRange.Value = Me.tbxAnlaggningsnummer.Value
targetWorkbook.Names("Projektnummer").RefersToRange.Value = Me.tbxProjektnummer.Value
targetWorkbook.Names("Projektledare").RefersToRange.Value = Me.tbxProjektledareNamn.Value
targetWorkbook.Names("ProjektledareTel").RefersToRange.Value = Me.tbxProjektledareTel.Value
targetWorkbook.Names("DelegeradNamn").RefersToRange.Value = Me.tbxDelegeradNamn.Value
targetWorkbook.Names("DelegeradTel").RefersToRange.Value = Me.tbxDelegeradTel.Value
targetWorkbook.Names("TeknikerNamn").RefersToRange.Value = Me.tbxTeknikerNamn.Value
targetWorkbook.Names("TeknikerTel").RefersToRange.Value = Me.tbxTeknikerTel.Value
targetWorkbook.Names("SBF110").RefersToRange.Value = Me.tbxSBF110.Value
targetWorkbook.Names("Anlaggningsagare").RefersToRange.Value = Me.tbxAnlaggningsagare.Value
targetWorkbook.Names("AgarAdress").RefersToRange.Value = Me.tbxAgarAdress.Value
targetWorkbook.Names("AgarPostnr").RefersToRange.Value = Me.tbxAgarPostnr.Value
targetWorkbook.Names("AgarPostort").RefersToRange.Value = Me.tbxAgarPostort.Value
targetWorkbook.Names("ObjektAdress").RefersToRange.Value = Me.tbxObjektAdress.Value
targetWorkbook.Names("ObjektPostor").RefersToRange.Value = Me.tbxObjektPostort.Value
targetWorkbook.Names("ObjektPostnr").RefersToRange.Value = Me.tbxObjektPostnr.Value
targetWorkbook.Names("Nyttjare").RefersToRange.Value = Me.tbxNyttjare.Value
targetWorkbook.Names("AnlSkotare1namn").RefersToRange.Value = Me.tbxAnlSkotare1namn.Value
targetWorkbook.Names("AnlSkotare1telefon").RefersToRange.Value = Me.tbxAnlSkotare1telefon.Value
targetWorkbook.Names("AnlSkotare2namn").RefersToRange.Value = Me.tbxAnlSkotare2namn.Value
targetWorkbook.Names("AnlSkotare2telefon").RefersToRange.Value = Me.tbxAnlSkotare2telefon.Value
targetWorkbook.Names("LedandeMontor").RefersToRange.Value = Me.tbxLedandeMontorNamn.Value
targetWorkbook.Names("LedandeMontorTelefon").RefersToRange.Value = Me.tbxLedandeMontorTelefon.Value
targetWorkbook.Names("LevAdress").RefersToRange.Value = Me.tbxLevAdress.Value
targetWorkbook.Names("LevPostort").RefersToRange.Value = Me.tbxLevPostort.Value
targetWorkbook.Names("LevPostnr").RefersToRange.Value = Me.tbxLevPostnr.Value
On Error GoTo 0
' Save the changes to the target workbook
targetWorkbook.Save
' Inform the user about the successful operation
MsgBox "Namngivna celler har uppdaterats i " & targetWorkbook.Name, vbInformation
End Sub
Private Sub cmbTaBort_Click()
' Get the selected value from cbxObjektsnamn
Dim selectedValue As String
selectedValue = CStr(Me.cbxObjektsnamn.Value)
' Find the corresponding row in DataFile.xlsm based on the selected value
Dim wsData As Worksheet
Set wsData = Workbooks("DataFile.xlsm").Sheets(1)
' Assuming the data is in columns B to Z (adjust as needed)
Dim dataRange As Range
Set dataRange = wsData.Range("A:Z")
' Find the row that corresponds to the selected value
Dim selectedRow As Variant
selectedRow = Application.Match(selectedValue, dataRange.Columns(1), 0)
If Not IsError(selectedRow) Then ' Check if a match is found
' Confirm with the user before removing the row
Dim confirmation As VbMsgBoxResult
confirmation = MsgBox("Är du säker på att du vill ta bort data för " & selectedValue & "?", vbQuestion + vbYesNo, "Tabort Data")
If confirmation = vbYes Then
' Remove the row
wsData.Rows(selectedRow).Delete
' Save changes to "DataFile.xlsm"
Workbooks("DataFile.xlsm").Save
' Close "DataFile.xlsm"
Workbooks("DataFile.xlsm").Close SaveChanges:=False
' Inform the user that the row has been removed
MsgBox "Data för " & selectedValue & " har tagits bort.", vbInformation
' Unload the user form
Unload Me
End If
Else
' Handle the case when no match is found
MsgBox "Inga matchande data hittades för " & selectedValue, vbExclamation
End If
End Sub
Private Sub cmbHelp_Click()
MsgBox "För att få hjälp med hur detta formulär fungerar se filen Personlig Vertygslist Information.dox som finns under mappen J:\EL\Säkerhet\Anläggarfirma Brandlarm\Mallar\Excel\Personlig verktygslist" & vbCrLf & vbCrLf & "CustomRibbon.xlam" & vbCrLf & "Version 1.0", vbOKOnly + vbQuestion, "Hjälp"
End Sub
The .xlam file i saved in AppData\Roaming\Microsoft\AddIns. This code/function is going to be used by several different people and needs to be easy installed. Even just adding this .xlam file to Excel addins is a bit hard for some users.
I'm not either sure what your issue is when you say "but i have a feeling that there's a better way to do this that doesn't force the user to only have one excel file open for the code to work"
But the other issue, to install an xlam can be done with a self installing code.
This only installs if no other workbooks are open. Make sure the users don't open the file from and email, they need to open it from a path or save it on the desktop then open it.
I'll just leave my Swedish comments in there since you are Swedish too.
#If VBA7 Then
Private Declare PtrSafe Function apiCopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
#Else
Private Declare Function apiCopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
#End If
Private Sub Workbook_open()
' Är makrot inte installerat
If Dir(Application.UserLibraryPath & "Your_file.xlam") = "" And Workbooks.Count = 0 Then
answer = MsgBox("Installera Your_file makro?", vbYesNo + vbQuestion, "Installera makro?")
If answer = vbNo Then
Exit Sub ' installera inte
Else
' kopiera filen som öppnades till add-in mappen
Result = apiCopyFile(ThisWorkbook.FullName, Application.UserLibraryPath & "Your_file.xlam", False)
AddIns("Your_file").Installed = True ' Aktivera makrot
If Result = 1 Then
' Avsluta Excel
On Error Resume Next
Application.Interactive = False
AppActivate "Microsoft Excel"
Application.Quit
Exit Sub 'Om inte stäng av fungerar avsluta makrot
End If
End If
End If
End sub
If you want to remotely be able to send updates to the users then you can add a code that checks for updates and asks the user if he/she wants to update.
This is also part of Workbook_open(). paste it below the last end if
pth = "X:\SomePathEveryoneHasAccessTo\"
' kolla efter uppdateringar
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(pth & "version.txt", 1)
Ver = CInt(objFile.ReadLine)
objFile.Close
' kolla efter uppdateringar
If Ver > 1 Then
ans = MsgBox("Ny version finns tillgänglig av Your_file makro." & vbCr & "Vill du uppdatera?", vbYesNo)
End If
If ans = vbYes Then
MsgBox ("Excel kommer stängas efter uppdateringen och du får öppna filen igen manuellt." & vbCr & "Uppdateringen är klar när den svarta rutan stängs automatiskt.")
Dim xWB As Workbook
Application.ScreenUpdating = False
For Each xWB In Application.Workbooks
If Not (xWB Is Application.ActiveWorkbook) Then
xWB.Close
End If
Next
Application.ScreenUpdating = True
MyFile = Environ("Temp") & "\Temp.bat"
fnum = FreeFile()
Open MyFile For Output As #fnum
If Application.OperatingSystem = "Windows (32-bit) NT 5.01" Then
Print #fnum, "ping -n 3 127.0.0.1>nul"
Else
Print #fnum, "timeout /T 3 >nul"
End If
Print #fnum, "copy /Y " & Chr(34) & pth & "Your_file.xlam" & Chr(34) & " " & Chr(34) & Application.UserLibraryPath & "Your_file.xlam" & Chr(34)
Close #fnum
Shell MyFile, vbNormalFocus
On Error Resume Next
Application.Interactive = False
AppActivate "Microsoft Excel"
Application.Quit
Exit Sub
End If
On line 10 in the code block above you see If Ver > 1 Then, here you need to change the 1 to whatever version of the macro you are sending out to the users.
Preferably you increase the number with 1 each time.
Save the xlam, and then copy the file to "X:\SomePathEveryoneHasAccessTo".
Then when all that is done, you can open the version.txt file in the same path and change it to the same version as you have in the macro code.
So what will happen is that when a user opens Excel, the workbook open code checks if it's the latest version from the version.txt file.
And it's not, so the code asks if it you want to update.
If yes then a temporary file is created with batch code that copies the xlam to the users xlam folder.
This code runs with a delay (timeout/ping part of the code), during this delay Excel closes itself to make sure the xlam can be overwritten.