About
Often times I find myself finding opportunities to automate simple and repetive tasks. Given the constraints of the workplace, I have little options in what is available or available to install on the machine to build the scripts and tools needed to automate tasks.
One constant in most environments is that they all use Microsoft Office which includes excel and in some cases Microsoft Access. Whith that we have access to VBA. It is here where I employ my creativity and abilities to make the most of what is available.
The below scripts are examples and copies of scripts I use on on a daily baisis to automate repetive taks saving time and energy for more demanding tasks. These are a handful examples and many are lost to time or too specific to a particular task to mention. You may note that some of the scripts are made with single purpose and resulablity in mind, while others are break the rule of single purpose and perform multiple functions in one script.
Generally my philosopy is to implement the SOLID and DRY principals when possible, however, if something works and does not have the need to be used elsewhere, I do not modify the function for resulablity.
Screen Updating
Public Sub TurnOffUpdates()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
End Sub
Public Sub TurnOnUpdates()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Hide Rows
A simple script that goes over a set range and hides rows based on value. In this instance it was used to hide rows with data that was less than 1.
'Hides rows if value is below 1
'Turns off screen updating while processing and turns it back on when done
Private Sub HideRow(Optional hideRows As Boolean = True)
Application.ScreenUpdating = False
Dim sht As Worksheet
Dim i As Integer
Dim total As Currency
Set sht = Application.ActiveWorkbook.Worksheets("Report")
sht.Range("7:37").Rows.Hidden = False
If hideRows = False Then
Application.ScreenUpdating = True
Exit Sub
End If
For i = 7 To 37
With sht
total = WorksheetFunction.Sum(.Range("H" & i & ":Q" & i))
If total < 1 Then
.Rows(i).Hidden = True
End If
End With
Next i
Application.ScreenUpdating = True
End Sub
Printing PDFs
The below example is a script used to loop through an table of unit numbers, update a value on the spreadsheet and print the results to a PDF. Value that is updated on the sptreasheet is referenced through a named range ReportUnitNumber and called using [ReportUnitNumber]. PDF’s are saved in the path defined in the variable pdfPath using a defined naming convention and at the end of execution, file explorer is opened to the PDF for ease of viewing the newly created PDF’s. Sorted PDFs were also emailed to the accounting deparment for processing using a script to automatically send the email.
Public Sub PrintPDF()
Application.ScreenUpdating = False
If Not SharedFunctions.CompareWorkBookName("IFTA", False) Then
GoTo EXITSUB
End If
Dim sht As Worksheet
Dim units() As Variant
Dim i As Integer
Dim pdfName As String
Dim pdfPath As String
Dim yearMonth As String
yearMonth = Format([ReportYear] & "-" & [ReportMonth], "yyyy-mm")
pdfPath = "C:\Users\jchura\06_Documents\IFTA\Files\Print\" & yearMonth & "_" & Format(Now, "yyyy-mm-dd") & "\"
MkDir pdfPath
Set sht = Application.ActiveWorkbook.Worksheets("Report")
units = [UnitTable[Unit]].Value
For i = 1 To UBound(units)
[ReportUnitNumber] = units(i, 1)
pdfName = units(i, 1) & "_" & yearMonth & ".pdf"
sht.ExportAsFixedFormat Type:=xlTypePDF, _
fileName:=pdfPath & pdfName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False
Next i
Shell "explorer.exe " & pdfPath, vbNormalFocus
EXITSUB:
Application.ScreenUpdating = True
End Sub
Gathering Files Names
The following function I used with a form that I created to loop through a list of invoices that were in an unsorted folder. The function would return a collection of PDFs, I would update a listbox with the values. The list box would then update a browser in the form to preview the PDF, from there I would rename the PDF within the form and move the file to a sorted folder.
Public Function GetAllPDF(searchDirectory As String) As Collection
Dim folder As Object
Dim file As Object
Dim pdfs As Collection
Dim i As Integer
Set folder = CreateObject("Scripting.FileSystemObject").GetFolder(searchDirectory)
Set pdfs = New Collection
i = 0
For Each file In folder.Files
If InStr(1, file, ".pdf", vbTextCompare) = 0 Then
GoTo NEXTFILE
End If
pdfs.Add file
i = i + 1
NEXTFILE:
Next file
Set GetAllPDF = pdfs
End Function
Moving and Renaming File
The below function moves and renames a file, will return false if the file already exists in the destination directory
Public Function MoveFile(oldLocation As String, newLocation As String) As Boolean
On Error Resume Next
Dim result As Boolean
result = False
On Error GoTo ERR
If Dir(newLocation, vbNormal) <> "" Then
GoTo ERR
End If
Name oldLocation As newLocation
result = True
ERR:
MoveFile = result
End Function
Emailing
Commonly this function would be used for sending invoices to finances, they requested that invoices be sent individually. This function would be called within a function that loops over invoices in a directory sending them then moving the invoice to folder called emailed.
Public Function SendEmail(emailRecipient As String, emailSubject As String, emailAttachement As String, emailBody As String, Optional priority As Integer = 1, Optional emailBCC As String = "") As Boolean
Dim emailApp As Object
Dim Email As Object
Dim result As Boolean
Dim emailBody As String
Dim emailRecipient As String
Dim emailBCC As String
On Error GoTo Err
result = False
Set emailApp = CreateObject("Outlook.Application")
Set Email = emailApp.CreateItem(0)
'Use 2 for high importance emails on importance 1 is regular
With Email
.To = emailRecipient
.BCC = emailBCC
.Subject = "Coded: " & emailSubject
.Attachments.Add emailAttachement
.body = emailBody
.Importance = priority
.Send
End With
Set emailApp = Nothing
Set Email = Nothing
result = True
Err:
If Err.Number > 0 Then
result = False
End If
SendEmail = result
End Function
Log Service
A smiple log service that I built for the auto emailed invoices, it was designed to help keep track of when what invoice was sent to finance. I can easily search the log withing powershell using the findstr -i command and flag
Public Sub WriteLog(message As String)
Dim filePath As String
Dim fso As FileSystemObject
Dim fileStream As TextStream
filePath = ThisWorkbook.Path & "\EmailLog.txt"
Set fso = New FileSystemObject
If Not fso.FileExists(filePath) Then
Set fileStream = fso.CreateTextFile(filePath)
fileStream.Close
End If
Set fileStream = fso.GetFile(filePath).OpenAsTextStream(ForAppending, 0)
fileStream.WriteLine (Format(Now, "yyyy-MM-dd hh:mm") & ": " & message)
fileStream.Close
End Sub