Blogs

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

'http://excelexperts.com/xla-routines-eeFinalFormatSheet    for updates on this sub routine

    Dim wksActive As Worksheet
 
    Set wksActive = ThisWorkbook.ActiveSheet
 
    If EE_SheetExists(strSheetName) = True Then
        With ThisWorkbook.Worksheets(strSheetName)
            .Cells.EntireColumn.A
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
 
'http://excelexperts.com/xla-routines-eeFormatCols    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
 
'http://excelexperts.com/xla-routines-eeRefreshPivots    for updates on this sub routine
    For Each wks In wbk.Worksheets
        On Error Resume Next
            For Each pvtTbl In wks.PivotTables
                pvtTbl.RefreshTable
                pvtTbl.Update
            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
 
'http://excelexperts.com/xla-routines-eeGetUnique    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
 
'http://excelexperts.com/xla-routines-eeCustomSort    for updates on this sub routine

    intCol = Application.WorksheetFunction.Match(strFldName, rngTable.Rows(1), 0)
 
    With rngTable.Parent.Sort
        .SortFields.Clear
        .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
 
'http://excelexperts.com/xla-routines-eeIsInArray    for updates on this function

    If UBound(Filter(arr, valueToCheck)) > -1 Then
        wordList = Join(arr, ",")
        ' start from the allegedly matched term ....
        st
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
 
'http://excelexperts.com/xla-routines-eeArrayCommonElements    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!
        'i
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
 
'http://excelexperts.com/xla-routines-eeGetColElements    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
 
'http://excelexperts.com/xla-routines-eeExtractColumnsFromFile    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
 
'http://excelexperts
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)
'http://excelexperts.com/xla-routines-eeFilterAndMove    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
 
'http://excelexperts.com/xla-routines-eeRearrangeColumns    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
 
'http://excelexperts.com/xla-routines-eeGetCellCount    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
 
'http://excelexperts.com/xla-routines-eeRangeSubtract    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
'http://excelexperts.com/xla-routines-eeRangeCommon    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
 
'http://excelexperts.com/xla-routines-eeRangeUnion    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
 
'http://excelexperts.com/xla-routines-eeRangeTrim    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
 
Nick's picture

XLA routines: EE_LastFridayOfMonth

EE_LastFridayOfMonth returns the last friday of the month that the date entered is in.
Function EE_LastFridayOfMonth(dt As Date) As Date
'Takes a date, returns last friday.
    Dim intLoop     As Integer
    Dim dtLast      As Date
 
'http://excelexperts.com/xla-routines-eeLastFridayOfMonth    for updates on this function

    dtLast = EE_LastDayOfMonth(dt)
    Do While Weekday((dtLast - intLoop)) <> vbFriday
        intLoop = intLoop + 1
    Loop
 
    EE_LastFridayOfMonth = dtLast - intLoop
End Function
Nick's picture

XLA routines: EE_NthWeekdayOfMonth

EE_NthWeekdayOfMonth returns the nth weekday of the month that a date is in. - so you could use this function to find the 3rd wednesday in the month (an IMM date for example), or the 2nd Friday...
Nick's picture

XLA routines: EE_BusinessDaysInDateRange

EE_BusinessDaysInDateRange takes 2 dates, and a holiday calendar, and returns the number of business days in the date range.
Function EE_BusinessDaysInDateRange(dt1 As Date, dt2 As Date, rngHolidays As range)
'Takes date 1, date 2 and works out the amount of business days between them
'- takes range of holidays
    Dim intLoop         As Date
    Dim intDaysCount    As Integer
 
'http://excelexperts.com/xla-routines-eeBusinessDaysInDateRange    for updates on this function

    For intLoop = dt1 To dt2 Step IIf(dt1 > dt2, -1, 1)
        If EE_IsBusinessDay(rngHolidays, i
Nick's picture

XLA routines: EE_LastBusinessDayOfMonth

EE_LastBusinessDayOfMonth takes a date, a holiday calendar and returns the last business day of the month that the date is in.
Function EE_LastBusinessDayOfMonth(dt As Date, rngHolidays As range) As Date
'- as above but rolls to the previous business day if the last bus day is a hol
'- also takes a range with the holiday calendar
'http://excelexperts.com/xla-routines-eeLastBusinessDayOfMonth    for updates on this function

    If EE_IsBusinessDay(rngHolidays, EE_LastDayOfMonth(dt)) Then
        EE_LastBusinessDayOfMonth = EE_LastDayOfMonth(dt)
    Else
        EE_LastBusiness
Nick's picture

XLA routines: EE_LastDayOfMonth

EE_LastDayOfMonth takes a date and returns the last day of the month that the date is in.
Function EE_LastDayOfMonth(dt As Date) As Date
'Takes a date and returns the last day of the month
'http://excelexperts.com/xla-routines-eeLastDayOfMonth    for updates on this function
    EE_LastDayOfMonth = DateAdd("d", -1, EE_FirstDayOfMonth(DateAdd("m", 1, dt)))
End Function
Nick's picture

XLA routines: EE_FirstDayOfMonth

EE_FirstDayOfMonth takes a date and returns the first business day of the month that the date 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
'http://excelexperts.com/xla-routines-eeFirstBusinessDayOfMonth    for updates on this function

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

XLA routines: EE_FirstDayOfMonth

EE_FirstDayOfMonth takes a date and returns the first day of the month that the date is in.
Function EE_FirstDayOfMonth(dt As Date) As Date
'Takes a date and returns the 1st day of the month
'http://excelexperts.com/xla-routines-eeFirstDayOfMonth    for updates on this function

    EE_FirstDayOfMonth = Format(Month(dt) & "/1/" & Year(dt), "mm/dd/yyyy")
End Function
Nick's picture

XLA routines: EE_SubtractBusinessDays

EE_SubtractBusinessDays takes a date, and a holiday calendar and subtracts a specified amount of business days.
Function EE_SubtractBusinessDays(dt As Date, rngHolidays As range, intBusinessDays As Integer) As Date
'Takes a date, a range of holidays, business days, and subtracts that amount of business days from the date.
    Dim intDays     As Integer
    Dim intLoop     As Integer
    Dim dtNew       As Date
 
'http://excelexperts.com/xla-routines-eeSubtractBusinessDays    for updates on this function

    If intBusinessDays = 0 Then
        EE_SubtractBusinessDays = dt
Nick's picture

XLA routines: EE_AddBusinessDays

EE_AddBusinessDays takes a date, and a holiday calendar and adds business days.
Function EE_AddBusinessDays(dt As Date, rngHolidays As range, intBusinessDays As Integer) As Date
'Takes a date, a range of holidays, business days, and adds that amount of business days to the date.
Nick's picture

XLA routines: EE_PrevBusinessDay

EE_PrevBusinessDay takes a date, and a holiday calendar and returns the previous business day.
Function EE_PrevBusinessDay(rngHolidays As range, dt As Date) As Date
'Takes a date, a range of holidays, and returns the previous business day
    Dim intPvs     As Integer
    Dim dtPvs      As Date
 
'http://excelexperts.com/xla-routines-eePrevBusinessDay    for updates on this function

    intPvs = 1
    Do While True
        dtPvs = DateAdd("d", 0 - intPvs, dt)
        If EE_IsBusinessDay(rngHolidays, dtPvs) Then
            EE_PrevBusinessDay = dtPvs
            Exit Func

Syndicate content