A basic module I load to each project for shared functionality
me@jaykilleen.com wrote this over 7 years ago and it was last updated almost 6 years ago.
When I start a new project in Excel one of my first steps (after changing the file format to .xlsm
) is to create a module called functions
and paste this code in.
This provides some basic functionality that I am constantly reusing such as get_last_row
or generate a YYYYMMDDHHMMSS
timestamp.
'copy the content of this gist into a new module in VBA (get to VBA by pressing Alt+F11)
'you then have access to the functions below from anywhere else in your workbook VBA scripts
'these scrips can be found at jaykilleen.com on at http://jaykilleen.com/posts/boilerplate-excel-vba-functions-module
Option Explicit
Function get_last_row(sheet As Worksheet, column_number As Integer) As Long
get_last_row = Sheets(sheet.Name).Cells(Rows.Count, column_number).End(xlUp).row
End Function
Function get_column_number(sheet As Worksheet, value As String, Optional row As Variant, Optional whole As Boolean) As Integer
Dim looks As String
If IsMissing(row) Then
row = 1
End If
If whole = False Then
get_column_number = Sheets(sheet.Name).Cells(row, 1).EntireRow.Find(What:=value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).column
Else
get_column_number = Sheets(sheet.Name).Cells(row, 1).EntireRow.Find(What:=value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).column
End If
End Function
Function get_row_number(sheet As Worksheet, value As Variant, column As Integer) As Integer
get_row_number = Sheets(sheet.Name).Cells(1, column).EntireColumn.Find(What:=value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).row
End Function
Function find_in_array(FindMe As String, myArray() As String)
Dim C As String
Dim ItemFound As Boolean
Dim MatchCase As Boolean
MatchCase = False
' Perform search
C = Chr$(1)
ItemFound = InStr(1, C & Join(myArray, C) & C, C & FindMe & C, 1 + MatchCase)
If ItemFound Then find_in_array = True
End Function
Function timestamp(time As String)
timestamp = Format(Now(), "YYYYMMDDhhmmss")
End Function
Public Function InCollection(col As Collection, key As String) As Boolean
Dim var As Variant
Dim errNumber As Long
InCollection = False
Set var = Nothing
Err.Clear
On Error Resume Next
var = col.Item(key)
errNumber = CLng(Err.Number)
On Error GoTo 0
'5 is not in, 0 and 438 represent incollection
If errNumber = 5 Then ' it is 5 if not in collection
InCollection = False
Else
InCollection = True
End If
End Function
Public Function CollectionToArray(myCol As Collection) As Variant
Dim result As Variant
Dim cnt As Long
ReDim result(myCol.Count)
For cnt = 0 To myCol.Count - 1
result(cnt) = myCol(cnt + 1)
Next cnt
CollectionToArray = result
End Function
Function FinancialYearFromDate(dDate As Date) As Long
Dim iMonth As Integer
Dim iYear As Integer
iMonth = Month(dDate)
iYear = Year(dDate)
If iMonth < 7 Then FinancialYearFromDate = iYear
If iMonth >= 7 Then FinancialYearFromDate = iYear + 1
End Function
Function ThisFinancialQuarterFromDate(dDate As Date) As Long
Dim iMonth As Integer
Dim iYear As Integer
iMonth = Month(dDate)
iYear = Year(dDate)
' when data is 31st March 2017
If iMonth < 4 Then ThisFinancialQuarterFromDate = iYear & 3
' when data is 30th June 2017
If iMonth < 7 And iMonth > 4 Then ThisFinancialQuarterFromDate = iYear & 4
' when data is 30th September 2016
If iMonth < 10 And iMonth > 7 Then ThisFinancialQuarterFromDate = (iYear + 1) & 1
' when data is 31st December 2016
If iMonth <= 12 And iMonth > 10 Then ThisFinancialQuarterFromDate = (iYear + 1) & 2
End Function
Function LastFinancialQuarterFromDate(dDate As Date) As Long
Dim iMonth As Integer
Dim iYear As Integer
iMonth = Month(dDate)
iYear = Year(dDate)
' when data is 31st March 2017
If iMonth < 4 Then LastFinancialQuarterFromDate = iYear & 2
' when data is 30th June 2017
If iMonth < 7 And iMonth >= 4 Then LastFinancialQuarterFromDate = iYear & 3
' when data is 30th September 2016
If iMonth < 10 And iMonth >= 7 Then LastFinancialQuarterFromDate = iYear & 4
' when data is 31st December 2016
If iMonth <= 12 And iMonth >= 10 Then LastFinancialQuarterFromDate = (iYear + 1) & 1
End Function
Function DateFromString(sDay As String, sMonth As String, sYear As String) As Date
DateFromString = DateValue(sDay & "/" & sMonth & "/" & sYear)
End Function
Function LastSavedTimeStamp() As String
LastSavedTimeStamp = ActiveWorkbook.BuiltinDocumentProperties("Last Save Time")
End Function
Sub ShowLastSavedTimeStamp()
Dim hours As Integer: hours = DateDiff("h", LastSavedTimeStamp, Now())
Dim minutes As Integer: minutes = DateDiff("n", LastSavedTimeStamp, Now())
Dim seconds As Integer: seconds = DateDiff("s", LastSavedTimeStamp, Now())
MsgBox "This workbook was Last Saved at " & vbNewLine & LastSavedTimeStamp & " or " & hours & ":" & (minutes Mod 60) & ":" & (seconds Mod 60) & " ago"
End Sub
Public Function UserName()
UserName = Environ$("UserName")
End Function
Function wsExists(wsName As String, Optional wb As Workbook) As Boolean
Dim ws As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
wsName = UCase(wsName)
For Each ws In wb.Sheets
If UCase(ws.Name) = wsName Then wsExists = True: Exit Function
Next
End Function
Function wbLocalPath(ByRef wb As Workbook) As String
Dim Ctr As Long
Dim objShell As Object
Dim UserProfilePath As String
'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then
'Replace forward slashes with back slashes
wbLocalPath = Replace(wb.FullName, "/", "\")
'Get environment path using vbscript
Set objShell = CreateObject("WScript.Shell")
UserProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
'Trim OneDrive designators
For Ctr = 1 To 6
'Debug.Print wbLocalPath
wbLocalPath = Mid(wbLocalPath, InStr(wbLocalPath, "\") + 1)
'Debug.Print wbLocalPath
Next
'Construct the name
wbLocalPath = UserProfilePath & "\OneDrive - USG Boral\" & wbLocalPath
Else
wbLocalPath = wb.FullName
End If
'Debug.Print "This Workbook.LocalPath is:"
'Debug.Print wbLocalPath
'Debug.Print "C:\Users\KilleenJ\OneDrive - USG Boral\50-59-AU-SIP\50-Excel-Application\ <- Do They Look Similar"
End Function