Creating a self install macro? - excel

Hello I create many macros for my co workers. The current method I have for distributing to another computer is going into the vba editor and importing.
I would really like to make a kind of "installer" for macros that would allow the user to install a new macro without having to go into the editor. I'm not sure this is even possible but any ideas are welcome!
Thanks!

You need to enable Microsoft Scripting Runtime library under references. (VBE -> Tools -> References. Check the box.)
Basically, you create a string that holds the code of the macro you want to install. Obviously, the string could be really long with many lines of code so you might need several string variables.
Dim toF As Workbook
Dim codeMod As CodeModule
Dim code As String
Dim fso As Scripting.FileSystemObject
Dim folder As folder
Dim name As String, file As String
Application.ScreenUpdating = False
Set fso = New FileSystemObject
Set folder = fso.GetFolder("C:\folder\here")
name = nameOfFileHere
file = folder & "\" & name
Set toF = Workbooks.Open(file)
'modify ThisWorkbook to place it elsewhere
Set codeMod = toF.VBProject.VBComponents("ThisWorkbook").CodeModule
'erase everything if code already exists
If codeMod.CountOfLines > 0 Then
codeMod.DeleteLines 1, codeMod.CountOfLines
End If
'dump in new code
code = _
"Private Sub Workbook_Open()" & vbNewLine & _
" Dim user as String" & vbNewLine & _
" Dim target as String" & vbNewLine & _
" user = Application.UserName" & vbNewLine & _
" target = """ & findUser & """" & vbNewLine & _
" If user = target then" & vbNewLine & _
" MsgBox ""I just dumped in some code.""" & vbNewLine & _
" End if" & vbNewLine & _
"End Sub" & vbNewLine
With codeMod
.InsertLines .CountOfLines + 1, code
End With
Application.ScreenUpdating = True

Related

Programmatically opening workbooks breaks events

I am generating a prompt list to open workbooks. However, doing so makes the event handlers in the opened .xlsm not run at all, but opening the same file directly through Windows Explorer works as expected.
I have tried adding
Application.EnableEvents = True
In different parts of the code
Public Sub Shft_O_open_misc_logs()
Dim openlog As Integer
Dim path As String, found As String
Dim rOnly As Boolean
Dim wb As Workbook
On Error GoTo leave
openlog = CInt(InputBox("Enter the numeric code for the log to open" & _
vbNewLine & vbNewLine & _
"[1] Grievance Log" & vbNewLine & _
"[2] Watch Box Counter" & vbNewLine & _
"[3] SF-813" & vbNewLine & _
"[4] OLD SF-813" & vbNewLine & _
"[5] Pending Consolidations" & vbNewLine & _
"[6] Recipient Group Listing" & _
vbNewLine, _
"Open log"))
Select Case openlog
Case 1:
path = "...\Grievance Log.xlsm"
Case 2:
path = "...\Watchbox Counter.xlsm"
Case 3:
path = "...\SF813.xlsm"
Case 4:
path = "...\813 Log FY15-16-17-18.xlsm"
Case 5:
path = "...\Workload Management Toolkit*"
rOnly = True
Case 6:
path = "...\Recipient Groups.xlsm"
Case Else:
GoTo leave
End Select
Set wb = Workbooks.Open(filename:=path, ReadOnly:=rOnly)
wb.Activate
ActiveWindow.WindowState = xlMaximized
leave:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

DocumentLibraryVersions

The following code was working but something happened and now it hangs on
Set DocVersions=Activeworkbook.DocumentLibraryVersions
I have even tried simple subs that with only the Dim and Set lines and it just hangs. I have also tried removing the Reference to the Microsoft Office 16.0 Object Library.
Not even sure what else to try
Sub getVersions()
Dim DocVersions As DocumentLibraryVersions
Dim DVersion As DocumentLibraryVersion
Dim clipobj As New DataObject
Dim clipdata As String
Dim i As Integer
Set DocVersions = ActiveWorkbook.DocumentLibraryVersions
i = DocVersions.Count
For Each DVersion In DocVersions
i = i - 1
Debug.Print i
clipdata = clipdata & DVersion.Index & vbTab & _
DVersion.Modified & vbTab & _
DVersion.ModifiedBy & vbTab & _
DVersion.Comments & vbCr
Debug.Print "index " & DVersion.Index
Debug.Print "comment " & DVersion.Comments
'Debug.Print "creator " & DVersion.Creator
Debug.Print "Modified Date " & DVersion.Modified
Debug.Print "Modified By " & DVersion.ModifiedBy
' Debug.Print "application " & DVersion.Application
Next
Set DocVersions = Nothing
Set DVersion = Nothing
clipobj.SetText clipdata
clipobj.PutInClipboard
MsgBox "Version Info Placed on Clipboard"
End Sub
I've had exactly the same problem when the following was hanging up the process:
Set DocVersions=Activeworkbook.DocumentLibraryVersions
After checking out the file for the first time and checking it in again, then the code continues as expected and does no longer hang at this point.

Error "Path/File Not Found" using the CopyFile method

I am trying to save a sheet as a PDF file to the desktop then copy the file to another location, using the CopyFile method.
I get errors
"File Not Found"
or
"Path Not Found"
When using the CopyFile method it creates a file on the desktop, then throws errors copying the file.
Previous to this I tried creating the pdf twice, one after the other, and it creates on the desktop and creates another in the relevant monthly folder.
I tried different syntaxes regarding the two variables.
Sub Save_Invoice_To_PDF()
Dim Fso As Scripting.FileSystemObject
Dim Invoice As Worksheet
Dim Fname As String
Dim Path1 As String
Dim Path2 As String
Dim PndSign As String
Dim Mth As String
Dim Mth1 As String
Set Invoice = Sheet1
PndSign = Chr(163)
Mth = Invoice.Range("A16").Value
Mth1 = MonthName(Month(Mth))
Path1 = "C:\Users\Peter\Desktop\"
Path2 = "C:\Users\Peter\Documents\Business\Sent Invoices\" & Mth1 & "\"
Fname = Range("C16").Value & " " & Range("A8").Value & " " & _
PndSign & "" & Range("E46").Value _
& " " & Format(Range("A16"), "dd-mm-yyyy") & ".pdf"
Application.ScreenUpdating = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Path1 & " " & Fname, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set Fso = New FileSystemObject
Fso.CopyFile Source:="C:\Users\Peter\Desktop\" & Fname, _
Destination:="C:\Users\Peter\Business\Invoices\Sent Invoices\ _
" & Mth1 & "\"
Set Fso = Nothing
Application.ScreenUpdating = True
End Sub
I would like to save one pdf to the desktop and copy that pdf to a monthly folder that is designated in the Mth1 variable which is obtained in part from the files Fname variable, i.e. Format(Range("A16"), "dd-mm-yyyy").
I faced the same problem, and from what I saw, this question is asked by many. I think you create the problem when before the FileCopy command there is a command to create the folder that will copy the file. So a compiler that is faster than the hard drive just can't find the folder, because that's what you're creating right now.
If you put a delay of 1 second before the command FileCopy ,
like this..
Application.Wait (Now + TimeValue("0:00:01"))
the problem will be solved
Your code is running in such a way, that it is trying to copy the file before it is being created.
I use sleep and while loop if file exist in particular directory then move the next command or wait or sleep.

vArray values not clearing out from previous loop in VBA

I have some vArrays which are not clearing out. The purspose of the macro is to work on a raw data tab which has 30+ tabs, each tab holding information for a specific office, 001-New York, etc. The macro is supposed to select x number of tabs (based on a reference file), copy them and save them into a new workbook. The problem is that instead of copying and saving from the raw data file it save the reference file instead. A For...Next loop is used to determine which tabs/offices to select & copy from the raw data file. The varrays are inside the loop and contain the names of the offices. When the code encounters the vArray the varray values are not clearing out when the loop circles back around.
Example:
'For 1' reference a cell with value of "8" so it populates 8 different vArray values (offices in this case). 'For 2' has a reference number of 5 and is supposed to populate 5 vArray values. It does this correctly as I can see the 5 new values in the locals window under vArray (1) thru vArray (5), however, vArray 6 thru 8 are showing values of the previous loop instead of 'Empty'. The vArray values are not clearing out when the macro loops.
sMasterListWBName is the reference file which tells the macro which tabs to copy from the raw data file and where to move the newly created workbook. The sub is also copying, saving, and distributing the reference file instead of the raw data file for some iterations of the loop (secondary issue--I will try to refrain from splitting the thread topic).
Thanks in advance to anyone who tries to answer this question.
Option Explicit
Dim iYear As Integer, iMonth As Integer, iVer As Integer, icount As Integer, iCount2 As Integer
Dim iLetter As String, iReport As String
Dim sMonth As String, sDate As String, sVer As String, sAnswer As String
Dim sFolderName As String, sManagerInitials As String
Dim iManagerNumber As Integer, iManagerStart As Integer, iTabNumber As Integer, iTabStart As Integer
Dim sMasterListWBName As String, sConsolidatedWBName As String, sExists As String
Dim oSheet As Object, oDistList As Object
Dim vArray(300) As Variant
Dim wbDistList As Workbook
Dim wsAgentListSheet As Worksheet, wsMain As Worksheet
Dim rCell As Range, rCell2 As Range, rCellTotal As Range
Public sFINorAgent As String
Sub Agent_Distribute()
On Error Resume Next
iYear = frm_fin_rep_main_distribute.txt_year
iMonth = frm_fin_rep_main_distribute.txt_month
iVer = frm_fin_rep_main_distribute.txt_version
sMonth = Right("0" & iMonth, 2)
sDate = iYear & "." & sMonth
sVer = "V" & iVer
sAnswer = MsgBox("Is the following information correct?" & vbNewLine & vbNewLine & _
"Report - " & frm_fin_rep_main.sLetter & vbNewLine & _
"Year - " & iYear & vbNewLine & _
"Month - " & sMonth & vbNewLine & _
"Name - " & frm_fin_rep_main.sReport & vbNewLine & _
"Version - " & sVer, vbYesNo + vbInformation, "Please verify...")
If sAnswer <> vbYes Then
Exit Sub
End If
Unload frm_fin_rep_main_distribute
frm_agent.Hide
Form_Progress
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
sConsolidatedWBName = ActiveWorkbook.Name
sMasterListWBName = "Dist Master List Final.xls"
If Not IsFileOpen(sMasterListWBName) Then
Workbooks.Open FileName:= _
"W:\Addins\01 GL - Distribution\" & sMasterListWBName, Password:="password"
Workbooks(sConsolidatedWBName).Activate
End If
Set oDistList = Workbooks(sMasterListWBName).Worksheets("Agent")
With oDistList
iManagerNumber = .Range("ManNumber2") 'range value = 66
For iManagerStart = 2 To iManagerNumber '2 to 66
If .Range("A" & iManagerStart) = "x" Then
iTabNumber = .Range("E" & iManagerStart) 'E2 to E66
sFolderName = .Range("F" & iManagerStart) 'F2 to F66
sManagerInitials = .Range("G" & iManagerStart) 'G2 to G66
For iTabStart = 1 To iTabNumber
vArray(iTabStart) = .Range("G" & iManagerStart).Offset(0, iTabStart)
Next iTabStart
If iTabNumber = 1 Then
Sheets(vArray(1)).Select
Else
Sheets(vArray(1)).Select
For iTabStart = 2 To iTabNumber
Sheets(vArray(iTabStart)).Select False
Next iTabStart
End If
ActiveWindow.SelectedSheets.Copy
' *** the following code is optional, remove preceding apostrophes from the following four lines to enable password protection ***
'For Each oSheet In ActiveWorkbook.Sheets
'oSheet.Protect "password"
'oSheet.EnableSelection = xlNoSelection
'Next
ActiveWorkbook.SaveAs FileName:= _
"W:\Financials\" & iYear & "\" & sDate & "\Report to Distribute Electronically\Department Reports\" _
& sFolderName & "\Current Year Financials" & "\" & "Y" & ") " & iYear & "-" & sMonth & " Agent Report Card " & sVer & " - " & sManagerInitials & ".xls"
ActiveWorkbook.Close
End If
iPercent = iManagerStart / iManagerNumber * 95
Task_Progress (iPercent)
Next iManagerStart
End With
Workbooks(sMasterListWBName).Close False
Task_Progress (100)
Unload frm_progress
Set oDistList = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Message_Done
frm_agent.Show (vbModeless)
End Sub
I fixed it. I just added "Workbooks(sWbName).activate" at the end of the loop to make sure the focus is back on the raw data file. Now all files are saving in the correct format and location. Case closed unless someone has anything else to add. Maybe someone knows the reason the macro was losing sight of its active sheet (saving reference file instead of raw data file). Thank you.

Faster Way to Import Excel Spreadsheet to Array With ADO

I am trying to import and sort data from a large excel report into a new file using Excel 2007 VBA. I have come up with two methods so far for doing this:
Have Excel actually open the file (code below), gather all data into arrays and output the arrays onto new sheets in the same file and save/close it.
Public Sub GetData()
Dim FilePath As String
FilePath = "D:\File_Test.xlsx"
Workbooks.OpenText Filename:=FilePath, FieldInfo:=Array(Array(2, 2))
ActiveWorkbook.Sheets(1).Select
End Sub
Use ADO to get all data out of the closed workbook, import the whole datasheet into an array (code below) and sort data from there and then output data into a new workbook and save/close that.
Private Sub PopArray() 'Uses ADO to populate an array that will be used to sort data
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim Getvalue, SourceRange, SourceFile, dbConnectionString As String
SourceFile = "D:\File_Test.xlsx"
SourceRange = "B1:Z180000"
dbConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=No"";"
Set dbConnection = New ADODB.Connection
dbConnection.Open dbConnectionString 'open the database connection
Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")
Arr = rs.GetRows
UpBound = UBound(Arr, 2)
rs.Close
End Sub
The test file used has about 65000 records to sort through (about a third of what I will end up using it for). I was kind of disappointed when the ADO version only performed marginally better than the open worksheet (~44 seconds vs ~40 seconds run time). I was wondering if there is some way to improve the ADO import method (or a completely different method - ExecuteExcel4Macro maybe? - if there is one) that would boost my speed. The only thing I could think of was that I am using "B1:Z180000" as my SourceRange as a maximum range that is then truncated by setting Arr = rs.GetRows to accurately reflect the total number of records. If that is what is causing the slow down, I'm not sure how I would go about finding how many rows are in the sheet.
Edit - I am using Range("A1:A" & i) = (Array) to insert data into the new worksheet.
This answer might not be what you are looking for but I still felt compelled to post it based on your side note [...] or a completely different method ]...].
Here, I am working with files of 200MB (and more) each which are merely text files including delimiters. I do not load them into Excel anymore. I also had the problem that Excel was too slow and needs to load the entire file. Yet, Excel is very fast at opening these files using the Open method:
Open strFileNameAndPath For Input Access Read Lock Read As #intPointer
In this case Excel is not loading the entire file but merely reading it line by line. So, Excel can already process the data (forward it) and then grab the next line of data. Like this Excel does not neet the memory to load 200MB.
With this method I am then loading the data in a locally installed SQL which transfers the data directly to our DWH (also SQL). To speed up the transfer using the above mething and getting the data fast into the SQL server I am transferring the data in chunks of 1000 rows each. The string variable in Excel can hold up to 2 billion characters. So, there is not problem there.
One might wonder why I am not simply using SSIS if I am already using a local installation of SQL. Yet, the problem is that I am not the one loading all these files anymore. Using Excel to generate this "import tool" allowed me to forward these tools to others, who are now uploading all these files for me. Giving all of them access to SSIS was not an option nor the possibility of using a destined network drive where one could place these files and SSIS would automatically load them (ever 10+ minutes or so).
In the end my code looks something like this.
Set conRCServer = New ADODB.Connection
conRCServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
& "DATA SOURCE=" & Ref.Range("C2").Value2 & ";" _
& "INITIAL CATALOG=" & Ref.Range("C4").Value & ";" _
& "Integrated Security=SSPI "
On Error GoTo SQL_ConnectionError
conRCServer.Open
On Error GoTo 0
'Save the name of the current file
strCurrentFile = ActiveWorkbook.Name
'Prepare a dialog box for the user to pick a file and show it
' ...if no file has been selected then exit
' ...otherwise parse the selection into it's path and the name of the file
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Extracts", "*.csv")
Application.FileDialog(msoFileDialogOpen).Title = "Select ONE Extract to import..."
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
strFileToPatch = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
Else
Exit Sub
End If
'Open the Extract for import and close it afterwards
intPointer = FreeFile()
Open strFileNameAndPath For Input Access Read Lock Read As #intPointer
intCounter = 0
strSQL = vbNullString
Do Until EOF(intPointer)
Line Input #intPointer, strLine
If Left(strLine, 4) = """###" Then Exit Sub
'*********************************************************************
'** Starting a new SQL command
'*********************************************************************
If intCounter = 0 Then
Set rstResult = New ADODB.Recordset
strSQL = "set nocount on; "
strSQL = strSQL & "insert into dbo.tblTMP "
strSQL = strSQL & "values "
End If
'*********************************************************************
'** Transcribe the current line into SQL
'*********************************************************************
varArray = Split(strLine, ",")
strSQL = strSQL & " (" & varArray(0) & ", " & varArray(1) & ", N'" & varArray(2) & "', "
strSQL = strSQL & " N'" & varArray(3) & "', N'" & varArray(4) & "', N'" & varArray(5) & "', "
strSQL = strSQL & " N'" & varArray(6) & "', " & varArray(8) & ", N'" & varArray(9) & "', "
strSQL = strSQL & " N'" & varArray(10) & "', N'" & varArray(11) & "', N'" & varArray(12) & "', "
strSQL = strSQL & " N'" & varArray(13) & "', N'" & varArray(14) & "', N'" & varArray(15) & "' ), "
'*********************************************************************
'** Execute the SQL command in bulks of 1.000
'*********************************************************************
If intCounter >= 1000 Then
strSQL = Mid(strSQL, 1, Len(strSQL) - 2)
rstResult.ActiveConnection = conRCServer
On Error GoTo SQL_StatementError
rstResult.Open strSQL
On Error GoTo 0
If Not rstResult.EOF And Not rstResult.BOF Then
strErrorMessage = "The server returned the following error message(s):" & Chr(10)
While Not rstResult.EOF And Not rstResult.BOF
strErrorMessage = Chr(10) & strErrorMessage & rstResult.Fields(0).Value
rstResult.MoveNext
Wend
MsgBox strErrorMessage & Chr(10) & Chr(10) & "Aborting..."
Exit Sub
End If
End If
intCounter = intCounter + 1
Loop
Close intPointer
Set rstResult = Nothing
Exit Sub
SQL_ConnectionError:
Y = MsgBox("Couldn't connect to the server. Please make sure that you have a working internet connection. " & _
"Do you want me to prepare an error-email?", 52, "Problems connecting to Server...")
If Y = 6 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Ref.Range("C7").Value2
.CC = Ref.Range("C8").Value2
.Subject = "Problems connecting to database '" & Ref.Range("C4").Value & "' on server '" & Ref.Range("C2").Value & "'"
.HTMLBody = "<span style=""font-size:10px"">---Automatically generated Error-Email---" & _
"</span><br><br>Error report from the file '" & _
"<span style=""color:blue"">" & ActiveWorkbook.Name & _
"</span>' located and saved on '<span style=""color:blue"">" & _
ActiveWorkbook.Path & "</span>'.<br>" & _
"Excel is not able to establish a connection to the server. Technical data to follow." & "<br><br>" & _
"Computer Name: <span style=""color:green;"">" & Environ("COMPUTERNAME") & "</span><br>" & _
"Logged in as: <span style=""color:green;"">" & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "</span><br>" & _
"Domain Server: <span style=""color:green;"">" & Environ("LOGONSERVER") & "</span><br>" & _
"User DNS Domain: <span style=""color:green;"">" & Environ("USERDNSDOMAIN") & "</span><br>" & _
"Operating System: <span style=""color:green;"">" & Environ("OS") & "</span><br>" & _
"Excel Version: <span style=""color:green;"">" & Application.Version & "</span><br>" & _
"<br><span style=""font-size:10px""><br>" & _
"<br><br>---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Exit Sub
SQL_StatementError:
Y = MsgBox("There seems to be a problem with the SQL Syntax in the programming. " & _
"May I send an error-email to development team?", 52, "Problems with the coding...")
If Y = 6 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Ref.Range("C8").Value2
'.CC = ""
.Subject = "Problems with the SQL Syntax in file '" & ActiveWorkbook.Name & "'."
.HTMLBody = "<span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---" & _
"</span><br><br>" & _
"Error report from the file '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Name & _
"</span>" & _
"' located and saved on '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Path & _
"</span>" & _
"'.<br>" & _
"It seems that there is a problem with the SQL-Code within trying to upload an extract to the server." & _
"SQL-Code causing the problems:" & _
"<br><br><span style=""color:green;"">" & _
strSQL & _
"</span><br><br><span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Exit Sub
End Sub
i think that #Mr. Mascaro is right the easiest way to past your data from a Recordset into a spreadsheet is:
Private Sub PopArray()
.....
Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")
'' This is faster
Range("A1").CopyFromRecordset rs
''Arr = rs.GetRows
End Sub
but if you still want to use Arrays you could try this:
Sub ArrayTest
'' Array for Test
Dim aSingleArray As Variant
Dim aMultiArray as Variant
'' Set values
aSingleArray = Array("A","B","C","D","E")
aMultiArray = Array(aSingleArray, aSingleArray)
'' You can drop data from the Array using 'Resize'
'' Btw, your Array must be transpose to use this :P
Range("A1").Resize( _
UBound(aMultiArray(0), 1) + 1, _
UBound(aMultiArray, 1) + 1) = Application.Transpose(aMultiArray)
End Sub

Resources