Hasoft Software Engineering Logo
Code Snippets
Sorting Links
About Us
Copyright © 2018 Hasoft
All rights reserved
Code Snippets
The LAselect Advanced Excel/VBA Sort Add-in Logo

Excel and Visual Basic Code Snippets

All Snippets: Copyright © 2018 Hasoft - All rights reserved

Safe RangeCopy

The standard VBA Range.Copy uses the clipboard. Any Cut & Paste operation by the user, even in another application, will fail if an automated (OnTime) VBA Range.Copy happens to overlap. The routine below does not suffer from this problem as it doesn't use the clipboard at all.
Public Sub RangeCopy(rngSource As Range, rngDestination As Range)
    Dim rowcnt As Long
    Dim colcnt As Long
    Dim bUpdate As Boolean

    bUpdate = Updating(False)           'Speed up by disabeling screen updating

    For rowcnt = 1 To rngSource.Rows.Count
        For colcnt = 1 To rngDestination.Columns.Count
            rngDestination(rowcnt, colcnt) = rngSource(rowcnt, colcnt)
        Next colcnt
    Next rowcnt

    Updating bUpdate
End Sub

Rotate Visual Basic (VB6/VBA) Variant Array By 90 Degrees

Rotate a Visual Basic (VB6/VBA) array by 90 degrees. Sometimes rows and columns are in the wrong orientation for processes like ReDim. This routine rotates such an array (and back).
Public Sub RotateVarArrayBy90(ArrayToRotate90 As Variant)
    Dim TempArray0() As Variant
    Dim i As Long, j As Long, lb1 As Long, lb2 As Long, ub1 As Long, ub2 As Long

    lb1 = LBound(ArrayToRotate90, 1)
    ub1 = UBound(ArrayToRotate90, 1)

    lb2 = LBound(ArrayToRotate90, 2)
    ub2 = UBound(ArrayToRotate90, 2)

    ReDim Preserve TempArray0(lb2 To ub2, lb1 To ub1)
    For i = lb2 To ub2
        For j = lb1 To ub1
            TempArray0(i, j) = ArrayToRotate90(j, i)
        Next j
    Next i

    ReDim ArrayToRotate90(lb2 To ub2, lb1 To ub1)
    ArrayToRotate90 = TempArray0
End Sub

Assure Folder Exists

Assure that a folder exists and create the folder if not. This prevents programs halting on missing folders when installing on virgin systems.
Public Sub AssureFolderExists(strFolderPath As String)
    Dim folderpath As String
    Dim folderpos As Long
    Dim newfolder As String

    Dim objFilesystem As Object

    Set objFilesystem = CreateObject("Scripting.FileSystemObject")

    'Create a local, properly slanted copy, terminated by a '\'

    folderpath = Replace(strFolderPath, "/", "\")

    folderpath = folderpath + IIf(Right(folderpath, 1) <> "\", "\", "")
    folderpos = 1

    'Assure that each folder in the path exists by creating it if neccessary

        folderpos = InStr(folderpos, folderpath, "\", vbTextCompare)
        newfolder = left(folderpath, folderpos)
        If Len(newfolder) < 1 Then Exit Do
        'Debug.Print "["; newfolder; "]", folderpos
        If objFilesystem.FolderExists(newfolder) = False Then
           objFilesystem.CreateFolder (newfolder)
        End If
        folderpos = folderpos + 1
End Sub

Public Sub AssureAllMyFolders()
    Dim RootFolder = "MyAppFolder\Experiments\"

    AssureFolderExists RootFolder + "Temp"
    AssureFolderExists RootFolder + "Backup"
    AssureFolderExists RootFolder + "Images"
    AssureFolderExists RootFolder + "Sounds"
End Sub

Remove Delays From Updating

If you're doing series of cell changes in Visual Basic for Applications, screenupdating and intermediate calculations cause delay upon delay. Calling "Updating False" prevents these delays while modifications are made. A closing call "Updating True" will do all postponed calculations and updates only once, often greatly speeding up the process.
Public Function Updating(bEnable As Boolean) As Boolean


    'Your Sub() of Function()
    '    Updating(False)
    '    Your code...
    '    Updating(True)

    'Or use this if the routine is (or could be) called from a routine that also calls
    'this function (prevents intermediate updates/recalc's/flickering):

    'Your Sub() of Function()
    '    Dim Boolean updatestatus
    '    updatestatus = Updating False           'Basically, this takes over mode of caller
    '    Your code...
    '    Updating updatestatus
    With Application
        Updating = .ScreenUpdating

        If bEnable = True Then
           If .Calculation <> xlCalculationAutomatic Then
              .Calculation = xlCalculationAutomatic
           End If

           If Updating <> True Then
              .ScreenUpdating = True
           End If
            If .Calculation <> xlCalculationManual Then
               .Calculation = xlCalculationManual
            End If
           If Updating <> False Then
              .ScreenUpdating = False
           End If
        End If
    End With
End Function

Get Application Drive

ApplicationDrive returns the backslash delimited drive letter the application is running from. I.e. "C:\".
Public Function ApplicationDrive() As String
    ApplicationDrive = left(ThisWorkbook.Path, 3)
End Function

Get Application Location

ApplicationLocation returns the backslash-delimited full path to the folder of the application.
Public Function ApplicationLocation() As String
    ApplicationLocation = ThisWorkbook.Path & "\"
End Function

Get Daynumber of n-th Weekday

Returns the daynumber of the n-th weekday of a month (i.e. 1st Sunday, 4th Thursday, -1 for last vbWeekday). Weekdays in standard vbNotation: vbSunday, vbMonday, ..., vbSaturday.

To get "Martin Luther King Day", the 3th Monday in January, do:

HolidayDate = DateSerial(theYear, 1, DayOfnthWeekDay(theYear, 1, vbMonday, 3))
Function DayOfnthWeekDay(theYear As Long, theMonth As Long, theWeekday As Long, Optional nth As Long = 1) As Long
    Dim firstDay As Long

    firstDay = 1                                'Find the first occurrance of the vbWeekday

    DayOfnthWeekDay = ((firstDay + vbSaturday) - WeekDay(DateSerial(theYear, theMonth, firstDay)) + theWeekday)

    If DayOfnthWeekDay > 7 Then                 'Did we overflow into the following week?
       DayOfnthWeekDay = DayOfnthWeekDay - 7    'Keep result within 7 days
    End If
    If nth > 1 Then                             'Not the first occurrance of vbWeekday wanted
       DayOfnthWeekDay = DayOfnthWeekDay + ((nth - 1) * 7)
    ElseIf nth < 0 Then
       Do While 1                               'Look for last vbWeekday occurrance in the month
          If Month(DateSerial(theYear, theMonth, firstDay) + DayOfnthWeekDay + 7) <> theMonth Then
             Exit Do
          End If
          DayOfnthWeekDay = DayOfnthWeekDay + 7
    End If
End Function

Determine if Date in Weekend

Returns Boolean True if a date falls inside a weekend.
Public Function IsWeekend(aDate As Date) As Boolean
    Dim DayOfWeek As Integer

    DayOfWeek = WeekDay(DateValue(aDate), vbSunday)
    IsWeekend = ((DayOfWeek = vbSaturday) Or (DayOfWeek = vbSunday))
End Function


Returns date of Easter for a given year.
Public Function Easter(Year As Long) As Date
    Dim GoldenNumber As Long
    Dim Century As Long
    Dim DiffGregJulLeapyear As Long
    Dim MetonicCorr As Long
    Dim WeekdayMarch21 As Long
    Dim Epacta As Long
    Dim MoonEquinoxMarch21 As Long
    Dim EasterDay As Long

    GoldenNumber = (Year Mod 19) + 1
    Century = (Year / 100) + 1
    DiffGregJulLeapyear = Int((3 * Century) / 4) - 12
    MetonicCorr = Int((8 * Century + 5) / 25) - 5
    WeekdayMarch21 = Int((Year * 5) / 4) - 10 - DiffGregJulLeapyear

    Epacta = ((11 * GoldenNumber + 20 + MetonicCorr - DiffGregJulLeapyear) Mod 30 + 30) Mod 30
    Epacta = IIf(Epacta = 24 Or (Epacta = 25 And GoldenNumber > 11), Epacta + 1, Epacta)

    MoonEquinoxMarch21 = 44 - Epacta
    MoonEquinoxMarch21 = IIf(MoonEquinoxMarch21 < 21, MoonEquinoxMarch21 + 30, MoonEquinoxMarch21)

    EasterDay = (MoonEquinoxMarch21 + 7) - (WeekdayMarch21 + MoonEquinoxMarch21) Mod 7

    Easter = DateSerial(Year, IIf(EasterDay > 31, 4, 3), IIf(EasterDay > 31, EasterDay - 31, EasterDay))
End Function

Scroll Cell to Home Position

Scrolls a given cell into the top-left home position.
Public Sub ScrollHome(rngCellToHome As Range)
    Application.ScreenUpdating = False

    With ActiveWindow
        .ScrollColumn = rngCellToHome.column
        .ScrollRow = rngCellToHome.row
    End With

    Application.ScreenUpdating = True
End Sub

Count Colored Cells

Count Colored Cells. FillColor can either be a color or point to a cell or range with a fillcolor.
Public Function CountColoredCells(FillColor As Variant, rngColorRange As Range, Optional SumContentsOfFillColor As Boolean = False) As Variant
    Dim rngCount As Range
    Dim fillcol As Long
    Dim Count As Variant

    'Detect if FillColor is a range and if so, take it's first cell's color

    If TypeName(FillColor) = "Range" Then
       fillcol = FillColor(1, 1).Interior.ColorIndex
       fillcol = FillColor
    End If

    'Sum or count cells with the specified FillColor

    If SumContentsOfFillColor = True Then
        For Each rngCount In rngColorRange
            If rngCount.Interior.ColorIndex = fillcol Then
               Count = WorksheetFunction.Sum(rngCount, Count)
            End If
        Next rngCount
        For Each rngCount In rngColorRange
            If rngCount.Interior.ColorIndex = fillcol Then
               Count = 1 + Count
            End If
        Next rngCount
    End If

    CountColoredCells = Count
End Function


The Unix 'tail' file appends messages to its end, hence the 'tail' designation. This is a Visual Basic (VB6/VBA) implementation of 'tail' and comes in handy debugging nasty problems. The tail file is always available after a crash while the debugging window is not. It works by selectively sending it error and progress messages from your project code. Each day a new 'tail' starts and builds a history of possible problems.
Const constTailPath "C:\Excel\Logging\"             'Path to logging folder
Public Sub Tail(strMessage As String, Optional Append As Boolean = True)
    Dim strTailName As String
    Dim fs As Object, objFile As Object
    Set fs = CreateObject("Scripting.FileSystemObject")

    strTailName = constTailPath & "Tail " & Format(NowDate, "dd-mm-yy") & ".txt"
    Set objFile = fs.OpenTextFile(strTailName, 8, Append, 0)
    Static StaticsValid As Boolean
    If Not StaticsValid Then
       StaticsValid = True
       objFile.WriteLine " "
       objFile.WriteLine "Tail (Re)started on " & Now
    End If
    objFile.WriteLine strMessage
End Sub

Add VBScript to Visual Basic (VB6/VBA)

Excel nor Visual Basic (VB6/VBA) has built-in support for Regular Expressions but this omission can easily be remedied by adding Microsoft VBScript to your project. Call this subroutine from the end of Workbook_Open() to automatically add it; no need to delve into complex menus. VBScript comes with certain versions of IE (it's needed for Active Server Pages) and most Windows PC's have several copies of it on disk. The OS will supply this installer with the most recent version it can find.

The LAselect data-selector/sorter is capable of using Regular Expressions in its processes and thusly sort data without having to mess with the cells on the spreadsheet. See the interactive LAselect Sorting Add-in TestBench on the menu to the left.
Private Sub AddVBScriptRegularExpressions55Reference()
    On Error Resume Next                                'In case already added
    ThisWorkbook.VBProject.References.AddFromGuid GUID:="{3F4DACA7-160D-11D2-A8E9-00104B365C9F}" _
                                                       , Major:=5, Minor:=5    
End Sub

Clear Columns to Infinity

Clears the contents from all columns in a range from an optional starting row. Does not remove formatting.
Private Sub ClearColumnsToInfinity(rngToClear As Range, Optional firstrowtodelete As Long = 1)
    Dim LastColumn As Integer
    Dim LastRow As Long, firstspacetoclear As Long
    Dim strAddress As String
    FindLastCell rngToClear.Worksheet, LastRow, LastColumn
    If LastRow > (rngToClear.Row + firstrowtodelete) Then
       Range(Cells(rngToClear.Row + firstrowtodelete, rngToClear.Column) _
           , Cells(LastRow, rngToClear.Column + (rngToClear.Columns.Count - 1))).ClearContents
    End If
End Sub

Delete Rows to Infinity

Delete all rows in a range from an optional starting row. The deleted rows will not be saved when the workbook is saved.
Public Sub DeleteRowsToInfinity(rngToClear As Range, Optional firstrowtodelete As Long = constCLEARBELOWTHIS)
    Dim LastColumn As Integer
    Dim LastRow As Long
    FindLastCell rngToClear.Worksheet, LastRow, LastColumn
    If LastRow > (rngToClear.Row + firstrowtodelete) Then
       rngToClear.Rows(vbNullString & (rngToClear.Row + firstrowtodelete) & ":" & LastRow & vbNullString).EntireRow.Delete shift:=xlUp
    End If
End Sub

Find Last Cell

This function finds the last used cell on a sheet and returns it both as row and column numbers and as a string containing a range address.
Private Function FindLastCell(ThisSheet As Worksheet, ByRef LastRow As Long, ByRef LastColumn As Integer) As String
    Dim rngUsedRange As Range
    Set rngUsedRange = ThisSheet.UsedRange
    LastRow = rngUsedRange.Row + (rngUsedRange.Rows.Count - 1)
    LastColumn = rngUsedRange.Column + (rngUsedRange.Columns.Count - 1)
    FindLastCell = Cells(LastRow, LastColumn).Address
End Function
[an error occurred while processing this directive]