Nick's blog

Nick's picture

XLA routines: EE_ExtractRow

EE_ExtractRow extracts a row from a data table, and puts it on a new sheet either transposed, or the same. - useful for extracting a record and analysing
Sub EE_ExtractRow(Optional SourceSht As Worksheet, Optional TargetSht As String, Optional RowToExtract As Long, Optional wb As Workbook, Optional blnTranspose As Boolean = True)
' takes the selected cell row as default
' copies and paste transpose onto a new sheet
' copies row and header onto sheet specified
'    for updates on this sub

    If SourceSht Is Nothing Then
Nick's picture

XLA routines: EE_FirstBusinessDayOfMonth

use EE_FirstBusinessDayOfMonth to find the first business day of the month that the date you are passing is in
Function EE_FirstBusinessDayOfMonth(dt As Date, rngHolidays As range) As Date
'- as above but rolls to the next business day if the first bus day is a hol
'- also takes a range with the holiday calendar
'    for updates on this function

    If EE_IsBusinessDay(rngHolidays, EE_FirstDayOfMonth(dt)) Then
        EE_FirstBusinessDayOfMonth = EE_FirstDayOfMonth(dt)
        EE_FirstBusinessDayOfMonth = 
Nick's picture

XLA routines: EE_ImportFromFile

Import a file's contents using EE_ImportFromFile
Sub EE_ImportFromFile(wbkFullPath As String, strSheet As String, rngTarget As range)
    Dim wbkSrc      As Workbook
    Dim wksSrc      As Worksheet
'    for updates on this function
    If EE_FileExists(wbkFullPath) = False Then Exit Sub
    Set wbkSrc = Workbooks.Open(wbkFullPath)
    Set wksSrc = wbkSrc.Worksheets(strSheet)
    rngTarget.PasteSpecial xlPasteValues
    rngTarget.PasteSpecial xlPasteFormats
Nick's picture

XLA routines: EE_FileExists

Function to return if a file exists
Function EE_FileExists(strFile As String) As Boolean
'    for updates on this function
    EE_FileExists = CreateObject("Scripting.FileSystemObject").FileExists(strFile)
End Function
Nick's picture

XLA routines: EE_IsArray

VBA's IsArray function doesn't work so well, so use this one for a n by n array.
Function EE_IsArray(varArgument As Variant) As Boolean
'- takes variant
'- returns whether it really is an array. (By checking whether theArray(1,1) exists)
'    for updates on this function

On Error GoTo IsNotArray
    EE_IsArray = True
    Dim temp
    temp = varArgument(1, 1)
    Exit Function
    EE_IsArray = False
End Function
Nick's picture

XLA routines: EE_ReplaceErrors

EE_ReplaceErrors replaces errors on your sheet with ""
Sub EE_ReplaceErrors(rng As range)
'Takes a range.. Replaces any cells containing errors with ""
'    for updates on this sub routine

    On Error Resume Next
        rng.SpecialCells(xlCellTypeFormulas, 16).value = ""
    Err.Clear: On Error GoTo 0: On Error GoTo -1
End Sub
Nick's picture

XLA routines: EE_SaveIfMe

EE_SaveIfMe is a handy developer sub that saves your work if you are the one running it. - it does not save if someone else is running it - never lose your work to crashes in Excel again !
Sub EE_SaveIfMe(strUserName As String)
'Takes a username as string
'Looks to see if application.username or ee_getusername is the string..
'If yes, save the workbook.

'    for updates on this sub routine

    Select Case strUserName
    Case Application.UserName, EE_GetUsername
    End Select
End Sub
Nick's picture

XLA routines: EE_OpenFromTemp

EE_OpenFromTemp is a time-saving function that copies a file to temp dir if it's different then opens it from temp - don't use this function if you are looking to modify the file
Function EE_OpenFromTemp(strFullFilePath As String) As Boolean
'Takes a full file name and path
'Opens the same file but from temp path
'Returns false if unsuccessful
'    for updates on this function

    Call EE_CopyFile(strFullFilePath, Environ("Temp"))
    On Error Resume Next
        Workbooks.Open (Environ("Temp") & Application.PathSeparator & 
Nick's picture

XLA routines: EE_CopyToTempIfDifferent

EE_CopyToTempIfDifferent copies a file to the temp dir if it has changed - useful if you are opening the same file from a directory multiple times
Function EE_CopyToTempIfDifferent(strFullFilePath As String) As Boolean
'Takes a full file name and path
'Copies it to temp dir (deleting existing file if it exists) Returns false if unsuccessful
'    for updates on this function

    On Error Resume Next
        Kill Environ("Temp") & Application.PathSeparator & EE_FileNameFromFilePath(strFullFilePath)
        Call EE_Copy
Nick's picture

XLA routines: EE_CopyFile

EE_CopyFile copies a file from one place to the next
Sub EE_CopyFile(strFullFilePath As String, strTarget As String)
'    for updates on this sub routine

    If EE_FileNameFromFilePath(strFullFilePath) = EE_FileNameFromFilePath(strTarget) Then
        'FileCopy strFullFilePath, strTarget
        Call CreateObject("Scripting.FileSystemObject").CopyFile(strFullFilePath, strTarget)
        'FileCopy strFullFilePath, strTarget & Application.PathSeparator & EE_FileNameFromFilePath(strFullFilePath)
        Call CreateObject("S
Nick's picture

XLA routines: EE_CellFlash

EE_CellFlash makes a cell colour flash
Sub EE_CellFlash(ByVal Target As range, Optional dblFlashColor As Double = 5287936)
'- takes a cell
'- changes the cell colour green for one second then back to original colour

    Dim dblColor                As Double
    Dim dblPattern              As Double
    Dim dblPatternColor         As Double
    Dim dblPatternColorIndex    As Double
    Dim dblThemeColor           As Double
    Dim dblTintAndShade         As Double
    Dim dblPatternTintAndShade  As Double
    Dim dblPatternThemeColor    As Double
    Dim dblChangeColor    
Nick's picture

XLA routines: EE_FinalFormatSheet

EE_FinalFormatSheet is a good sub routine to use when creating a set of results to clean up the sheet
Sub EE_FinalFormatSheet(strSheetName As String)
'Takes a sheet name as string
'If sheet doesn't exist, exit sub
'Sub autofits the cols
'Selects A2
'Freezes Panes

'    for updates on this sub routine

    Dim wksActive As Worksheet
    Set wksActive = ThisWorkbook.ActiveSheet
    If EE_SheetExists(strSheetName) = True Then
        With ThisWorkbook.Worksheets(strSheetName)
Nick's picture

XLA routines: EE_FormatCols

EE_FormatCols is a handy routine that takes a source range that is formatted, and applies the formatting to a target range
Sub EE_FormatCols(rngSource As range, rngTarget As range)
    Dim rngTgtHdr   As range
    Dim rngHd       As range
    Dim rngFound    As range
    Dim rngData     As range
    Dim dblDataRows As Double
'    for updates on this sub routine

    Set rngData = Intersect(rngTarget.CurrentRegion, rngTarget.CurrentRegion.Offset(1))
    Set rngTgtHdr = rngTarget.Rows(1)
    dblDataRows = rngData.Row
Nick's picture

XLA routines: EE_RefreshPivots

EE_RefreshPivots refreshes the pivot tables on a workbook
Sub EE_RefreshPivots(wbk As Workbook)
    Dim wks     As Worksheet
    Dim pvtTbl  As PivotTable
'    for updates on this sub routine
    For Each wks In wbk.Worksheets
        On Error Resume Next
            For Each pvtTbl In wks.PivotTables
            Next pvtTbl
        Err.Clear: On Error GoTo 0: On Error GoTo -1
    Next wks
    Set wks = Nothing
    Set pvtTbl = Nothing
End Sub
Nick's picture

XLA routines: EE_GetUnique

EE_GetUnique returns the unique items in an array
Function EE_GetUnique(arrDupes As Variant) As Variant
    Dim objDict     As Object
    Dim intLoop     As Long
'    for updates on this function

    Set objDict = CreateObject("Scripting.Dictionary")
    For intLoop = LBound(arrDupes, 1) To UBound(arrDupes, 1)
        objDict(arrDupes(intLoop, 1)) = 1
    Next intLoop
    EE_GetUnique = Application.Transpose(WorksheetFunction.Transpose(objDict.Keys))
    Set objDict = Nothing
End Function
Nick's picture

XLA routines: EE_CustomSort

EE_CustomSort sorts data using Excel 2007 and above
Sub EE_CustomSort(rngTable As range, strFldName As String, strCustomSortOrder As String)
    Dim intCol As Integer
'    for updates on this sub routine

    intCol = Application.WorksheetFunction.Match(strFldName, rngTable.Rows(1), 0)
    With rngTable.Parent.Sort
        .SortFields.Add Key:=Intersect(rngTable.Columns(intCol), rngTable.Columns(intCol).Offset(1)), _
            SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
Nick's picture

XLA routines: EE_IsInArray

EE_IsInArray is a function to check whether a value is in an array
Function EE_IsInArray(arr As Variant, valueToCheck As String, _
    Optional exactMatch As Boolean = True) As Boolean
    Dim wordList              As String
    Dim startPosition         As Long
    Dim nextCommaPosition     As Long
    Dim matchedTerm           As String
'    for updates on this function

    If UBound(Filter(arr, valueToCheck)) > -1 Then
        wordList = Join(arr, ",")
        ' start from the allegedly matched term ....
Nick's picture

XLA routines: EE_ArrayCommonElements

EE_ArrayCommonElements returns the common elements in 2 arrays
Function EE_ArrayCommonElements(array1 As Variant, _
                          array2 As Variant) As Variant
    Dim tempArray     As Variant
    Dim i             As Long
'    for updates on this function

    ' start with a single element
    ReDim tempArray(0)
    ' if element in first array exists in second array, keep it
    For i = LBound(array1) To UBound(array1)
        If EE_IsInArray(array2, CStr(array1(i))) Then  ' found!
Nick's picture

XLA routines: EE_GetColElements

Use EE_GetColElements to get an range of column elements
Function EE_GetColElements(rngTableWithHeader As range, strColName As String) As Variant
    Dim intCol As Integer
    Dim rng As range
    Dim arr As Variant
    Dim arr2
'    for updates on this function

    intCol = Application.WorksheetFunction.Match(strColName, rngTableWithHeader.Rows(1), 0)
    With rngTableWithHeader
        Set rng = Intersect(.Columns(intCol), .Columns(intCol).Offset(1))
        EE_GetColElements = rng
        If rngTableWith
Nick's picture

XLA routines: EE_SortTwoRangesOnCommonIds

EE_SortTwoRangesOnCommonIds - Advanced sub routine to find out what are common and what are missing between 2 data sets
Sub EE_SortTwoRangesOnCommonIds(rngTableWithHeader1 As range, rngTableWithHeader2 As range, strColName As String)
'a sub that takes 2 ranges of data, with a common unique ID, and sorts both sets
'of data so that the common IDs are at the top in the same row on both sheets, and the ones that
'don't match are at the bottom - this should be optimised so that it is very quick with huge amounts
'of data (500,000 rows)..
    Dim arr1            As Variant
    Dim a
Nick's picture

XLA routines: EE_ExtractColumnsFromFile

Use EE_ExtractColumnsFromFile to extract only certain cols from a closed file to a new sheet - uses ADODB
Sub EE_ExtractColumnsFromFile(strSourceFile As String, strSrcSheet As String, rngHeadings As range, strTgtSheet As String, Optional blnDispMsg As Boolean = False)
    Dim rngTgt      As range
    Dim rngEach     As range
    Dim objConn     As Object
    Dim objRst      As Object
    Dim strSQL      As String
    Dim strFlds     As String
    Dim x           As Integer
'    for updates on this sub routine
Nick's picture

XLA routines: EE_FilterAndCopyToNewSheet

Use EE_FilterAndCopyToNewSheet to filter data in a table, and copy the results to a new sheet
Sub EE_FilterAndCopyToNewSheet(rngTable As range, strHeading As String, strCriteria As String, strCopyToSheet As String, Optional blnAppendToExistingSheet As Boolean = True)
'- same as filter and remove, but instead copies results to a new sheet
'- replaces the sheet if it exists already
    Dim intHeadCol      As Integer
    Dim wksTgt          As Worksheet
    Dim wbk             As Workbook
    Dim rngData         As range
    Dim rngTgt          As range
Nick's picture

XLA routines: EE_FilterAndMove

Use EE_FilterAndMove to filter data, and move that data to a new sheet - depends on EE_FilterAndCopyToNewSheet and EE_FilterAndRemove
Sub EE_FilterAndMove(rngTable As range, strHeading As String, strCriteria As String, strCopyToSheet As String)
'    for updates on this sub routine

   Call EE_FilterAndCopyToNewSheet(rngTable, strHeading, strCriteria, strCopyToSheet)
   Call EE_FilterAndRemove(rngTable, strHeading, strCriteria)
End Sub
Nick's picture

XLA routines: EE_RearrangeColumns

Use EE_RearrangeColumns to rearrange the cols for a data table
Sub EE_RearrangeColumns(SourceSheet As Worksheet, ParamArray TargetHeadings() As Variant)
    Dim intHeadings     As Integer
    Dim intCol          As Integer
    Dim rngTable        As range
    Dim rngColCopy      As range
    Dim rngPaste        As range
'    for updates on this sub routine

    Set rngTable = EE_Table(CStr(TargetHeadings(LBound(TargetHeadings))), SourceSheet)
    For intHeadings = LBound(TargetHeadings) To UBound(TargetHeading
Nick's picture

XLA routines: EE_GetCellCount

EE_GetCellCount returns the cell count from a range
Private Function EE_GetCellCount(rng As range) As Double
    Dim dblRowCount     As Double
    Dim dblColCount     As Double
'    for updates on this function

    dblRowCount = rng.Rows.Count
    dblColCount = rng.Columns.Count
    EE_GetCellCount = dblRowCount * dblColCount
    dblRowCount = Empty
    dblColCount = Empty
End Function
Nick's picture

XLA routines: EE_RangeSubtract

Use EE_RangeSubtract to subtract a range from another
Public Function EE_RangeSubtract(ByVal rng1 As range, ByVal rng2 As range) As range
    Dim rngSmall        As range
    Dim rngBig          As range
    Dim rngIntersect    As range
    Dim rngTopRows      As range
    Dim rngBtmRows      As range
    Dim rngLeftCols     As range
    Dim rngRightCols    As range
    Dim rngUnion        As range
    Dim strMsg          As String
'    for updates on this function

    If rng1.Areas.Count > 1 Or rng2.Areas.Count > 
Nick's picture

XLA routines: EE_Concatenate

EE_Concatenate concatenates a range like the CONCATENATE Excel function should work
Function EE_Concatenate(rng As range, strDelimiter As String) As String
'-concatenates the cells in the range
'Returns string..
Nick's picture

XLA routines: EE_RangeCommon

Use EE_RangeCommon to return the range that is common between 2 ranges
Function EE_RangeCommon(rng1 As range, rng2 As range) As range
'    for updates on this function
    Set EE_RangeCommon = Intersect(rng1, rng2)
End Function
Nick's picture

XLA routines: EE_RangeUnion

Use EE_RangeUnion to add ranges together - Takes up to 6 ranges
Function EE_RangeUnion(rng1 As range, Optional rng2 As range, Optional rng3 As range, _
    Optional rng4 As range, Optional rng5 As range, Optional rng6 As range) As range
'    for updates on this function

    If rng2 Is Nothing Then
        Set EE_RangeUnion = rng1
    ElseIf rng3 Is Nothing Then
        Set EE_RangeUnion = Union(rng1, rng2)
    ElseIf rng4 Is Nothing Then
        Set EE_RangeUnion = Union(rng1, rng2, rng3)
    ElseIf rng5 Is Nothing The
Nick's picture

XLA routines: EE_RangeTrim

Use EE_RangeTrim to trim a range that is passed to date functions to make the calc quicker
Function EE_RangeTrim(rng As range) As range
'Returns a new range containing only the populated cells
'- use RangeTrim for all the date functions to prevent looping through the whole range.

    Dim rngC As range
'    for updates on this function

    If rng.Cells.Count = 1 Then
        If rng.value <> vbNullString Then
            Set EE_RangeTrim = rng
            Exit Function
        End If
    End If
    On Error Resume Next

Syndicate content