gen_vba_library

Option Explicit

' NOTE: replace gen.ErrHandler calls with below where the ErrHandler proc will not be available:
'    Debug.Print "Error in ", cProcName, vbCrLf, "Err no: ", Err.Number, _
                vbCrLf, "Err Description: ", Err.Description

' Global constants / variables
Public Const gcSupportDetails = "<support_email_add_here>"
Public Const gcErrMsgOn As Boolean = True
Public Const gcMsgLimit As Integer = 5
Public gvErrCount As Integer
Public gvErrBefore As Integer
Public gvErrString As String
Public gvErrNotes As String

Sub InitialiseGlobalVars()
On Error GoTo InitialiseGlobalVars_err

    ' Local constants / variables
    Const cProcName = "InitialiseGlobalVars"

    'Initialise Globals
    gvErrCount = 0
    gvErrBefore = 0
    gvErrString = Empty
    gvErrNotes = Empty

InitialiseGlobalVars_exit:
    Exit Sub

InitialiseGlobalVars_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Sub

Function NextAvailableRow()
On Error GoTo NextAvailableRow_err
' Goes from currently active cell and finds the next available row

    ' Local constants / variables
    Const cProcName = "NextAvailableRow"

    If ActiveCell.Value = "" Then
        NextAvailableRow = ActiveCell.row
    Else
        NextAvailableRow = ActiveCell.End(xlDown).row + 1
    End If

NextAvailableRow_exit:
    Exit Function

NextAvailableRow_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Function

Function NextAvailableCol()
On Error GoTo NextAvailableCol_err
' Goes from currently active cell and finds the next available row

    ' Local constants / variables
    Const cProcName = "NextAvailableCol"

    If ActiveCell.Value = "" Then
        NextAvailableCol = ColNoToLetter(ActiveCell.Column)
    Else
        NextAvailableCol = ColNoToLetter(ActiveCell.End(xlToRight).Column + 1)
    End If

NextAvailableCol_exit:
    Exit Function

NextAvailableCol_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Function

Function LastRow(p_sheet As String, p_cell_address As String)
On Error GoTo LastRow_err
' Looks from address sent in as parameter to find the last row populated before a break

    ' Local constants / variables
    Const cProcName = "LastRow"

    LastRow = Sheets(p_sheet).Range(p_cell_address).End(xlDown).row

LastRow_exit:
    Exit Function

LastRow_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Function

Function LastCol(p_sheet As String, p_cell_address As String)
On Error GoTo LastCol_err
' Looks from address sent in as parameter to find the last column populated before a break, returns a letter

    ' Local constants / variables
    Const cProcName = "LastCol"

    LastCol = Gen.ColNoToLetter(Sheets(p_sheet).Range(p_cell_address).End(xlToRight).Column)

LastCol_exit:
    Exit Function

LastCol_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Function

Function ColNoToLetter(pColNo As Integer)
On Error GoTo ColNoToLetter_err
' Goes from currently active cell and finds the next available row

    ' Local constants / variables
    Const cProcName = "ColNoToLetter"
    Dim vNumberOne As Integer
    Dim vNumberTwo As Integer
    Dim vLetterOne As String
    Dim vLetterTwo As String

    vNumberOne = 0
    vNumberTwo = 0
    vLetterOne = Empty
    vLetterTwo = Empty

    vNumberOne = Int((pColNo - 1) / 26)
    vNumberTwo = pColNo - (vNumberOne * 26)
    vLetterTwo = Chr(vNumberTwo + 64)

    If vNumberOne >= 1 Then
        vLetterOne = Chr(vNumberOne + 64)
    End If

    ColNoToLetter = vLetterOne & vLetterTwo

ColNoToLetter_exit:
    Exit Function

ColNoToLetter_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Function

Function SheetExists(pSheetName As String, _
                                       pCreateIfNotExists As Boolean, _
                                       pGoToSheet As Boolean, _
                                       pAcceptPartialMatch As Boolean) As Boolean
On Error GoTo SheetExists_err

    ' Local constants / variables
    Const cProcName = "SheetExists"
    Dim vSheet As Worksheet
    Dim vSheetNo As Integer
    Dim vCurrSheetName As String
    Dim vSearchFor As String

    vSheetNo = 0
    vCurrSheetName = Empty
    vSearchFor = Empty

    If pAcceptPartialMatch = True Then
        vSearchFor = "*" & pSheetName & "*"
    Else
        vSearchFor = pSheetName
    End If

    For Each vSheet In Worksheets
        vSheetNo = vSheetNo + 1
        vCurrSheetName = vSheet.Name
        If vCurrSheetName Like vSearchFor Then
            SheetExists = True
            Exit For
        Else
            SheetExists = False
        End If
    Next

    If pCreateIfNotExists = True Then
        If SheetExists = False Then
            Sheets.add().Name = pSheetName
            vCurrSheetName = pSheetName
        End If
    End If

    If pGoToSheet = True Then

        ' Use vCurrSheetName as if accepting partial matches pSheetname may not exist
        Sheets(vCurrSheetName).Select
        Range("A1").Select
        ActiveWindow.DisplayGridlines = False
    End If

SheetExists_exit:
    Exit Function

SheetExists_err:
    'If Err.Number = 9 Then
    '    Debug.Print "Err No:" & vbTab & Err.Number & ", " & vbTab & "Err Desc:" & vbTab & Err.Description
    '    Resume Next
    'Else
        Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
        Resume Next
    'End If

End Function

Sub ExtendRowHeight(Optional pAutoSize As Boolean = True, _
                                        Optional pAlignToTop As Boolean = True, _
                                        Optional pAddToColHeight As Single = 10, _
                                        Optional pStartFromRow As Integer = 2)
On Error GoTo ExtendRowHeight_err

    ' Local constants / variables
    Const cProcName = "ExtendRowHeight"
    Dim vEnd As Integer
    Dim vRow As Integer

    ActiveSheet.Range("A" & pStartFromRow).Select
    vEnd = ActiveCell.CurrentRegion.Rows.Count
    vRow = 0

    Rows(pStartFromRow & ":" & vEnd).Select

    ' Set based row height to autosize if required
    If pAutoSize = True Then
        With Selection
            .ShrinkToFit = False
        End With
    End If

    ' Set vertical alignment if required
    If pAlignToTop = True Then
        With Selection
            If ActiveCell.RowHeight > 15 Then
                .VerticalAlignment = xlTop
            Else
                .VerticalAlignment = xlCenter
            End If
        End With
    End If

    ActiveSheet.Range("A" & pStartFromRow).Select

    ' Loop through to ad x to the row height (if <> 0
    If pAddToColHeight <> 0 Then
        For vRow = pStartFromRow To vEnd
            ActiveCell.RowHeight = ActiveCell.RowHeight + pAddToColHeight
            ActiveCell.Offset(1, 0).Select
        Next vRow
    Else
        Debug.Print "Parameter passed in to add 0 to row height so no need to loop through"
    End If

    ActiveSheet.Range("A" & pStartFromRow).Select

ExtendRowHeight_exit:
    Exit Sub

ExtendRowHeight_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Sub


Sub ErrHandler(pErrSource, pErrNo, pErrDesc)
On Error GoTo ErrHandler_err

    ' Local constants / variables
    Const cProcName = "ErrHandler"

    ' Set description on user defined errors (or revert to pErrDesc for others)
    If pErrNo = 40001 Then
        gvErrNotes = "A user defined error occurred processing the " & gcBatchScript & " procedure."
    ElseIf pErrNo = 40002 Then
        gvErrNotes = "A user defined error occurred during the " & pErrSource & " procedure."
    ElseIf pErrNo = 50000 Then
        gvErrNotes = "User defined error raised to test error handling functionality."
    Else
        gvErrNotes = pErrDesc
    End If

    ' Update error count and logging details
    gvErrCount = gvErrCount + 1
    gvErrString = gvErrString & Chr(10) & Chr(10) & "ErrCount: " & gvErrCount & ", " & _
                          "Error occurred in " & pErrSource & " procedure, " & Chr(10) & _
                          "Err_No: " & pErrNo & ", " & _
                          "Err_Desc: " & gvErrNotes

    ' Uncomment to test error handling procedure
    '--Error (50001)

    If gcErrMsgOn And gvErrCount <= gcMsgLimit Then
        ' Raise message for user
        MsgBox ("An error occurred in the " & pErrSource & " procedure / function, details:" & vbCrLf & _
        "____________________________________________________________________________" & _
        vbCrLf & vbCrLf & _
        "Error Number:" & vbTab & pErrNo & vbCrLf & _
        "Description:" & vbTab & gvErrNotes & vbCrLf & _
        "____________________________________________________________________________" & _
        vbCrLf & vbCrLf & _
        "If you are still experiencing problems please report the issue to: " & gcSupportDetails & _
        "." & vbTab & vbCrLf & vbCrLf)

        ' **** alternative msg for imports: ****
        'vbCrLf & vbCrLf & _
        '"Please note the following points:" & vbCrLf & vbCrLf & _
        '">  You must have access to the " & gcRawDataPath & " directory to run this spreadsheet." & vbCrLf & _
        '">  You can confirm this by going to the Start Menu, Run and entering " & gcRawDataPath & vbCrLf & _
        '">  This spreadsheet should be contained within the same directory" & vbCrLf & _
        '"    (shortcuts are okay as long as they link to this directory as the target address)" & vbCrLf & vbCrLf & _
        '"If you are still experiencing problems please report the issue to: " & gcSupportDetails & "." & vbTab & vbCrLf & _
        '"Details of this error should be recorded in the Log sheet." & vbCrLf)
    End If

ErrHandler_exit:
    Exit Sub

ErrHandler_err:
    Debug.Print "*** Error in error handling procedure. Oh dear, something has gone very wrong! ***"
    gvErrCount = gvErrCount + 1
    gvErrString = gvErrString & Chr(10) & Chr(10) & "ErrCount: " & gvErrCount & ", " & _
                          "Error occurred in " & cProcName & " procedure, " & Chr(10) & _
                          "Err_No: " & pErrNo & ", " & _
                          "Err_Desc: " & pErrDesc
    Resume Next

End Sub


Sub LikeNew(Optional pClearData As Boolean = True)
On Error GoTo LikeNew_err

    ' Local constants / variables
    Const cProcName = "LikeNew"

    ' Select all cells
    Cells.Select

    ' LikeNew format, width, height, colours and borders for all cells
    With Selection
        .ColumnWidth = 8.43
        .RowHeight = 15
        .Font.Bold = False
        .NumberFormat = "General"
        .Interior.ColorIndex = xlNone
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone

        ' Clear data if required
        If pClearData = True Then
            .ClearContents
        End If

    End With

    Range("A1").Select
    ActiveWindow.FreezePanes = False

LikeNew_exit:
    Exit Sub

LikeNew_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Sub

Function Levenshtein(ByVal string1 As String, ByVal string2 As String) As Long

Dim i As Long, j As Long
Dim string1_length As Long
Dim string2_length As Long
Dim distance() As Long

string1 = LCase(string1)
string2 = LCase(string2)
string1_length = Len(string1)
string2_length = Len(string2)
ReDim distance(string1_length, string2_length)

For i = 0 To string1_length
    distance(i, 0) = i
Next

For j = 0 To string2_length
    distance(0, j) = j
Next

For i = 1 To string1_length
    For j = 1 To string2_length
        If Asc(Mid$(string1, i, 1)) = Asc(Mid$(string2, j, 1)) Then
            distance(i, j) = distance(i - 1, j - 1)
        Else
            distance(i, j) = Application.WorksheetFunction.Min _
            (distance(i - 1, j) + 1, _
             distance(i, j - 1) + 1, _
             distance(i - 1, j - 1) + 1)
        End If
    Next
Next

Levenshtein = distance(string1_length, string2_length)

End Function

Function CompareDates(pDate1 As Date, pDate2 As Date) As Long
On Error GoTo CompareDates_err

    ' Local constants / variables
    Const cProcName = "CompareDates"
    Dim v As Long  ' value
    Dim y1 As Long ' year
    Dim m1 As Long ' month
    Dim d1 As Long ' day
    Dim y2 As Long ' year
    Dim m2 As Long ' month
    Dim d2 As Long ' day

    ' Initialise variables
    v = 0
    y1 = Year(pDate1)
    m1 = Month(pDate1)
    d1 = Day(pDate1)
    y2 = Year(pDate2)
    m2 = Month(pDate2)
    d2 = Day(pDate2)

    If d1 <> d2 Then
        v = v + 1
    End If
    If m1 <> m2 Then
        v = v + 1
    End If
    If y1 <> y2 Then
        v = v + 1
    End If

    CompareDates = v ^ 2

CompareDates_exit:
    Exit Function

CompareDates_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Function

Function mmm_to_mm(mon As String) As String
On Error GoTo mmm_to_mm_err

    ' Local constants / variables
    Const cProcName = "mmm_to_mm"

    mon = LCase(mon)
    If mon = "jan" Then
        mmm_to_mm = "01"
    ElseIf mon = "feb" Then
        mmm_to_mm = "02"
    ElseIf mon = "mar" Then
        mmm_to_mm = "03"
    ElseIf mon = "apr" Then
        mmm_to_mm = "04"
    ElseIf mon = "may" Then
        mmm_to_mm = "05"
    ElseIf mon = "jun" Then
        mmm_to_mm = "06"
    ElseIf mon = "jul" Then
        mmm_to_mm = "07"
    ElseIf mon = "aug" Then
        mmm_to_mm = "08"
    ElseIf mon = "sep" Then
        mmm_to_mm = "09"
    ElseIf mon = "oct" Then
        mmm_to_mm = "10"
    ElseIf mon = "nov" Then
        mmm_to_mm = "11"
    ElseIf mon = "dec" Then
        mmm_to_mm = "12"
    Else
        mmm_to_mm = "error"
        MsgBox ("Input not recognised, please enter the month as a 3 character string")
    End If

mmm_to_mm_exit:
    Exit Function

mmm_to_mm_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next
End Function

Function MinGTDate(pThreshold As Date, pRange As Range) As Date
On Error GoTo MinGTDate_err

    ' Local constants / variables
    Const cProcName = "MinGTDate"
    Dim vMin As Date
    Dim c As Variant

    'Debug.Print "Args (pThreshold and pRange) set to: " & pThreshold & " " & _
                pRange.Address
    vMin = Application.Max(pRange)
    'Debug.Print "vMin initialised to: " & vMin

    ' loop through range
    For Each c In pRange.Cells
        If c.Value > pThreshold Then
            If c.Value < vMin Then
                vMin = c.Value
            End If
        End If
    Next

    If vMin > pThreshold Then
        MinGTDate = vMin
    Else
        MinGTDate = Empty
    End If

MinGTDate_exit:
    Exit Function

MinGTDate_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next
End Function


Sub FileLoop(pDirPath As String, _
             Optional pPrintToSheet = False, _
             Optional pStartCellAddr = "$A$1", _
             Optional pCheckCondition = False, _
             Optional pFileNameContains = "xxx", _
             Optional pProcToRunOnWb)

On Error GoTo PrintFileList_err

    ' Local constants / variables
    Const cProcName = "FileLoop"
    Dim vFileList() As String ' array for file names
    Dim i As Integer          ' iterator for file name array
    Dim j As Integer          ' match counter
    Dim c As String
    ' variables for optional param pProcToRunOnWb
    Dim vFullPath As String
    Dim vTmpPath As String
    Dim wb As Workbook

    vFullPath = Application.ThisWorkbook.FullName
    vFileList = GetFileList(pDirPath)
    c = pStartCellAddr
    j = 0

    For i = LBound(vFileList) To UBound(vFileList)
        ' if condition is met (i.e. filename cotains text or condition is not required...
        If pCheckCondition And InStr(1, vFileList(i), pFileNameContains, vbTextCompare) > 0 _
           Or Not pCheckCondition Then

            ' print name to sheet if required...
            If pPrintToSheet Then
                Range(c).Offset(j, 0).Value = vFileList(i)
                j = j + 1 ' increment row offset
            End If

            ' open wb to run macro if required...
            If pProcToRunOnWb <> "" Then
                Application.DisplayAlerts = False ' set alerts off so that macro can run in other wb
                vTmpPath = pDirPath & "\" & vFileList(i)
                Set wb = Workbooks.Open(Filename:=vTmpPath)
                Workbooks(wb.Name).Activate
                Application.Run "'" & vFullPath & "'!" & pProcToRunOnWb
                wb.Close (True) ' save and close workbook
                Application.DisplayAlerts = True ' set alerts back on
            End If

        End If

        Debug.Print vFileList(i)
    Next i

   ' clean up
   Set wb = Nothing

PrintFileList_exit:
    Exit Sub

PrintFileList_err:
    Debug.Print "Error in ", cProcName, vbCrLf, "Err no: ", Err.Number, _
                vbCrLf, "Err Description: ", Err.Description
    Resume Next

End Sub


' function to return an array based on files in a directory, call via
' FileLoop for output and macro options options

Function GetFileList(pDirPath As String) As Variant
On Error GoTo GetFileList_err

    ' Local constants / variables
    Const cProcName = "GetFileList"
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim c As Double           ' upper bound for file name array
    Dim i As Double           ' iterator for file name array
    Dim vFileList() As String ' array for file names

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(pDirPath)
    c = objFolder.Files.Count
    i = 0

    ReDim vFileList(1 To c)  ' set bounds on file array now we know count

    'Loop through the Files collection
    For Each objFile In objFolder.Files
        'Debug.Print objFile.Name
        i = i + 1
        vFileList(i) = objFile.Name
    Next

    'Clean up!
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing

    GetFileList = vFileList

GetFileList_exit:
    Exit Function

GetFileList_err:
    Debug.Print "Error in ", cProcName, vbCrLf, "Err no: ", Err.Number, _
                vbCrLf, "Err Description: ", Err.Description
    Resume Next

End Function


Sub Import_Text_Data(pSheet As String, _
                     pPath As String, _
                     pDelim As String, _
                     pStartCell As String)
On Error GoTo Import_Text_Data_err

    ' local constants / variables
    Const cProcName = "GetFileLists"
    Dim vUsePath As String
    Dim vLastRow As Double
    Dim vLastCol As String

    Debug.Print "Starting import process for file (" & pPath & ")"

    vUsePath = "TEXT;" & pPath
    Debug.Print "Use path set to: " & vUsePath
    vLastRow = Gen.LastRow(pSheet, pStartCell)
    vLastCol = Gen.LastCol(pSheet, pStartCell)

    ' clear old data
    ActiveWorkbook.Sheets(pSheet).Select
    Range(pStartCell & ":" & vLastCol & vLastRow).ClearContents

    Debug.Print "Attempting to import data..."
    With ActiveSheet.QueryTables.add(Connection:= _
        vUsePath, Destination:=Range(pStartCell))
        .Name = pSheet
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1254
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = pDelim
        .TextFileColumnDataTypes = 1
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Range("A1").Select

Import_Text_Data_exit:
    Exit Sub

Import_Text_Data_err:

    If Err.Number = 5 Then
        Debug.Print "Error no: " & Err.Number & " occurred here, error handled"
        Debug.Print "Err Desc: " & Err.Description
    ElseIf Err.Number = 7 Then
        Debug.Print "Error no " & Err.Number & " occurred here, error handled" & vbCrLf & _
            vbTab & "(Issue likely to be because there is no data in this file)."
        Debug.Print "Err Desc: " & Err.Description; ""
    Else
        Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
        Resume Next
        End If
    Resume Next

End Sub


Function Fibonacci(n As Double) As Double
On Error GoTo Fibonacci_err

    ' Local constants / variables
    Const cProcName = "Fibonacci"

    If n <= 1 Then
        Fibonacci = n
    Else:
        Fibonacci = Fibonacci(n - 1) + Fibonacci(n - 2)
    End If

Fibonacci_exit:
    Exit Function

Fibonacci_err:
    Call Gen.ErrHandler(cProcName, Err.Number, Err.Description)
    Resume Next

End Function


Sub UnprotectSheetWithoutPwd()
    'Breaks worksheet password protection.
    Dim i As Integer, j As Integer, k As Integer
    Dim l As Integer, m As Integer, n As Integer
    Dim i1 As Integer, i2 As Integer, i3 As Integer
    Dim i4 As Integer, i5 As Integer, i6 As Integer
    On Error Resume Next
    For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
    For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
    For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
    For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
    ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
        Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
        Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
    If ActiveSheet.ProtectContents = False Then
        MsgBox "One usable password is " & Chr(i) & Chr(j) & _
            Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
            Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
         Exit Sub
    End If
    Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next
End Sub


' still to be tested
Sub DelSheets(p_sheet_to_keep)
    Dim ws As Worksheet
    Application.DisplayAlerts = False

    For Each ws In Worksheets
        If ws.Name.lower() <> p_sheet_to_keep.lower() Then ws.Delete
    Next
    Application.DisplayAlerts = True
End Sub


Function FindLast(find_text As String, within_text As Range) As Double

    Dim i As Integer

    i = Len(within_text.Value) ' start at last character and work back

    Do While Mid(within_text.Value, i, 1) <> find_text
        i = i - 1
    Loop

    FindLast = i

End Function