Visual Basic for Applications/Printable version

From Wikibooks, open books for an open world
Jump to navigation Jump to search


Visual Basic for Applications

The current, editable version of this book is available in Wikibooks, the open-content textbooks collection, at
https://en.wikibooks.org/wiki/Visual_Basic_for_Applications

Permission is granted to copy, distribute, and/or modify this document under the terms of the Creative Commons Attribution-ShareAlike 3.0 License.

Character 1D Arrays

Summary[edit | edit source]

  • This VBA code module is intended for any Microsoft Office application that supports VBA.
  • It allows strings to be loaded into one-dimensional arrays one character per element, and to join such array characters into single strings again.
  • The module is useful in splitting the characters of a single word ,something that the Split method cannot handle.

Notes on the code[edit | edit source]

Copy all of the procedures below into a VBA standard module, save the workbook as a xlsm type, then run the top procedure to show that the process is accurate.

The VBA Code Module[edit | edit source]

Sub testStrTo1DArr()
    ' run this to test array string load
    ' and array to string remake procedures
    
    Dim vR As Variant, vE As Variant
    Dim sStr As String, bOK As Boolean, sOut As String
    
    sStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
    
    'split string into array elements
    bOK = StrTo1DArr(sStr, vR, False)
    
    If bOK = True Then
        'optional array transfer
        vE = vR
        
        'remake string from array
        sOut = Arr1DToStr(vE)
        
        'show that output = input
        MsgBox sStr & vbCrLf & sOut
    Else
        Exit Sub
    End If

End Sub

Function StrTo1DArr(ByVal sIn As String, vRet As Variant, _
                    Optional ByVal bLB1 As Boolean = True) As Boolean
    ' Loads string characters into 1D array (vRet). One per element.
    ' Optional choice of lower bound. bLB1 = True for one-based (default),
    ' else bLB1 = False for zero-based. vRet dimensioned in proc.

    Dim nC As Long, sT As String
    Dim LB As Long, UB As Long
    
    If sIn = "" Then
        MsgBox "Empty string - closing"
        Exit Function
    End If
    
    'allocate array for chosen lower bound
    If bLB1 = True Then
        ReDim vRet(1 To Len(sIn))
    Else
        ReDim vRet(0 To Len(sIn) - 1)
    End If
    LB = LBound(vRet): UB = UBound(vRet)

    'load charas of string into array
    For nC = LB To UB
        If bLB1 = True Then
            sT = Mid$(sIn, nC, 1)
        Else
            sT = Mid$(sIn, nC + 1, 1)
        End If
        vRet(nC) = sT
    Next

    StrTo1DArr = True

End Function
    
Function Arr1DToStr(vIn As Variant) As String
    ' Makes a single string from 1D array string elements.
    ' Works for any array bounds.
        
    Dim nC As Long, sT As String, sAccum As String
    Dim LB As Long, UB As Long
    
    LB = LBound(vIn): UB = UBound(vIn)

    'join characters of array into string
    For nC = LB To UB
        sT = vIn(nC)
        sAccum = sAccum & sT
    Next

    Arr1DToStr = sAccum

End Function

See Also[edit | edit source]

External Links[edit | edit source]


Array Data To Immediate Window

Summary[edit | edit source]

This VBA code module allows the listing of arrays in the immediate window. So that the user can see examples of its use, it makes use of various procedures that fill the array for demonstration and testing. The VBA code runs in MS Excel but is easily adapted for any of the MS Office products that run VBA. Clearly, mixed data varies in length and in its number of decimal points. This module displays the array neatly taking account of the variations that might otherwise disrupt the layout. It can decimal point align the data or not, according to internal options.

Code Notes[edit | edit source]

  • DispArrInImmWindow() is the main procedure. It formats and prints data found on the two dimensional input array. It prints on the VBA Editor's Immediate Window. Options include the printing of data as found or making use of decimal rounding and alignment. The entire output print is also available as a string for external use. The process depends on monospaced fonts being set for any display, including the VBA editor.
  • RndAlphaToArr(), RndNumericToArr(), and RndMixedDataToArr() load an array with random data. The data is random in the content and length of elements, but in addition, numerics have random integer and decimal parts. Each allows adjustment of options internally to accommodate personal preferences.
  • TabularAlignTxtOrNum() is not used in this demonstration. It is included for those who prefer to format each individual column of an array during the loading process. Its input variant takes a single string or number and returns the formatted result in a user-set fixed field width. The number of decimal places of rounding can be set. Note that when all data in a column of a numeric array is loaded with the same parameters, the result is always decimal point alignment.
  • WriteToFile() is a monospaced font, text file-making procedure. If the file name does not exist, it will be made and saved automatically. Each save of text will completely replace any previously added. It is added here in case a user needs to save an output greater than that possible for the Immediate Window. The Immediate Window is limited to about two hundred lines of code, so large arrays should make use of the main procedure's sOut string. Again, wherever outputs from the main procedure are used, monospaced fonts are assumed.
  • Note that the user might add a procedure to export large values of sOut, the formatted string, to the clipboard. Procedures exist elsewhere in this series that will accomplish this.

The VBA Module[edit | edit source]

Copy the entire code module into a standard VBA module, save the file as type .xlsm and run the top procedure. Be sure to set monospaced fonts for the VBA editor or the object will have been defeated.

Updates[edit | edit source]

  • 26 Nov 2019: Adjusted DispArrInImmWindow() code to better estimate maximum column width, taking account of imposed decimal places.
Option Explicit

Private Sub testDispArrInImmWindow()
    'Run this to display a selection of data arrays
    'in the immediate window. Auto formatting
    'includes rounding and decimal point alignment.
    'Alternative is to print data untouched.
    'SET IMMEDIATE WINDOW FONT TO MONOSPACED
    'Eg: Consolas or Courier.
    
    Dim vArr As Variant, vArr2 As Variant, sOutput As String
     
    'clear the immediate window
    ClearImmWindow
    
    'UNFORMATTED random length alpha strings
    RndAlphaToArr vArr, 5, 6        'length setting made in proc
    vArr2 = vArr
    Debug.Print "UNFORMATTED"
    DispArrInImmWindow vArr, False, 2
    'FORMATTED random length alpha strings
    Debug.Print "FORMATTED"
    DispArrInImmWindow vArr2, True, 2
    
    
    'UNFORMATTED random length numbers and decimals
    RndNumericToArr vArr, 5, 6      'various settings made in proc
    vArr2 = vArr
    Debug.Print "UNFORMATTED"
    DispArrInImmWindow vArr, False, 2
    'FORMATTED random length numbers and decimals
    Debug.Print "FORMATTED"
    DispArrInImmWindow vArr2, True, 2
    
        
    'UNFORMATTED random alpha and number alternating columns
    RndMixedDataToArr vArr, 5, 6    'various settings made in proc
    vArr2 = vArr
    Debug.Print "UNFORMATTED"
    DispArrInImmWindow vArr, False, 2
    'FORMATTED random alpha and number alternating columns
    Debug.Print "FORMATTED"
    DispArrInImmWindow vArr2, True, 2, sOutput
    
    'output whole string version to a log file
    'WriteToFile sOutput, ThisWorkbook.Path & "\MyLongArray.txt"

End Sub

Private Sub ClearImmWindow()
    
    'NOTES
    'Clears VBA immediate window down to the insertion point,
    'but not beyond. Not a problem as long as cursor is
    'at end of text, but otherwise not.
    'Clear manually before any neat work.
    'Manual clear method: Ctrl-G then Ctrl-A then Delete.
    
    'Max display in immediate window is 199 lines,
    'then top lines are lost as new ones added at bottom.
    'No reliable code method exists.
    
    Debug.Print String(200, vbCrLf)
    
End Sub

Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
                                  Optional ByVal nNumDecs As Integer = 2, _
                                     Optional sOut As String)

    '--------------------------------------------------------------------------
    'vA :               Input 2D array for display in the immediate window.
    'sOut:              Alternative formatted output string.
    'bFormatAlignData : True: applies decimal rounding and decimal alignment,
    '                   False: data untouched with only basic column spacing.
    'nNumDecs:          Sets the rounding up and down of decimal places.
    '                   Integers do not have zeros added at any time.
    'Clear the immediate window before each run for best results.
    'The immediate window at best lists 199 lines before overwrite, so
    'consider using sOut for large arrays.  'ie; use it in a text file
    'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
    'so set the font VBA editor or any textbox to Courier or Consolas.
    'To set different formats for EVERY column of an array it is best to add
    'the formats at loading time with the procedure TabularAlignTxtOrNumber().
    '--------------------------------------------------------------------------
    
    'messy when integers are set in array and decimals is set say to 3.
    'maybe the measurement of max element width should include a measure
    ' for any dot or extra imposed decimal places as well
    'different for integers and for existing decimals
        
    Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
    Dim sPadding As String, sDecFormat As String, sR As String, sE As String
    Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
    Dim nMaxFieldWidth As Integer, bSkip As Boolean
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    'get bounds of input array
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
    
    ReDim vD(LB1 To UB1, LB2 To UB2) 'display
    ReDim vC(LB2 To UB2)             'column max
    
    '--------------------------------------
    'set distance between fixed width
    'fields in the output display
    nInterFieldSpace = 3
    'not now used
    nMaxFieldWidth = 14
    '--------------------------------------
    
    If nNumDecs < 0 Then
        MsgBox "nNumDecs parameter must not be negative - closing"
        Exit Sub
    End If
        
    'find widest element in each column
    'and adjust it for any imposed decimal places
    For c = LB2 To UB2
        n = 0: m = 0
        For r = LB1 To UB1
            'get element length
            If IsNumeric(vA(r, c)) Then
                If Int(vA(r, c)) = vA(r, c) Then 'is integer
                    n = Len(vA(r, c)) + 1 + nNumDecs
                Else 'is not integer
                    If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
                        n = Len(vA(r, c))
                    Else  'add the difference in length as result of imposed decimal places
                        n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
                    End If
                End If
            Else
                n = Len(vA(r, c))
            End If
            
            If n > m Then m = n 'update if longer
        Next r
        'store the maximum length
        'of data in each column
        vC(c) = m
    Next c
        
    For c = LB2 To UB2
        For r = LB1 To UB1
            sE = Trim(vA(r, c))

            If bFormatAlignData = False Then
                sDecFormat = sE
                nP = InStr(sE, ".")
                bSkip = True
            End If

            'make a basic format
            If bSkip = False Then
                nP = InStr(sE, ".")
                'numeric with a decimal point
                If IsNumeric(sE) = True And nP > 0 Then
                    sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
                'integer
                ElseIf IsNumeric(sE) = True And nP <= 0 Then
                    sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
                'alpha
                ElseIf IsNumeric(sE) = False Then
                    sDecFormat = sE
                End If
            End If
  
            'adjust field width to widest in column
            bSkip = False
            sPadding = Space$(vC(c))
            'numeric with a decimal point
            If IsNumeric(sE) = True And nP > 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'integer
            ElseIf IsNumeric(sE) = True And nP <= 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'alpha
            ElseIf IsNumeric(sE) = False Then
                vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
            End If
        Next r
    Next c
        
    'output
    sOut = ""
    For r = LB1 To UB1
        For c = LB2 To UB2
            sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
        Next c
        Debug.Print sR             'print one row in imm window
        sOut = sOut & sR & vbCrLf  'accum one row in output string
        sR = ""
    Next r
    sOut = sOut & vbCrLf
    Debug.Print vbCrLf

End Sub

Private Sub RndAlphaToArr(vIn As Variant, nRows As Integer, nCols As Integer)
    'loads a 2D array in place with random string lengths
            
    Dim sT As String, sAccum As String, nMinLenStr As Integer
    Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
    Dim nAsc As Integer, r As Long, c As Long
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
        
    '--------------------------------------------------
    'set minimum and maximum strings lengths here
    nMinLenStr = 2   'the minimum random text length
    nMaxLenStr = 8  'the maximum random text length
    '--------------------------------------------------
    
    Randomize
    For r = LB1 To UB1
        For c = LB2 To UB2
            nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
            
            'make one random length string
            For n = 1 To nLenWord
                nAsc = Int((90 - 65 + 1) * Rnd + 65)
                sT = Chr$(nAsc)
                sAccum = sAccum & sT
            Next n
            
            'store string
            vIn(r, c) = sAccum
            sAccum = "": sT = ""
        Next c
    Next r

End Sub

Private Sub RndNumericToArr(vIn As Variant, nRows As Integer, nCols As Integer)
    'loads a 2D array in place with random number lengths
    
    Dim sT1 As String, sT2 As String, nMinLenDec As Integer, sSign As String
    Dim sAccum1 As String, sAccum2 As String, nMaxLenDec As Integer
    Dim nLenInt As Integer, nLenDecs As Integer, nMinLenInt As Integer
    Dim n As Long, r As Long, c As Long, nAsc As Integer, nMaxLenInt As Integer
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
      
    '--------------------------------------------------
    'set user minimum and maximum settings here
    nMinLenDec = 0   'the minumum decimal part length
    nMaxLenDec = 4   'the maximum decimal part length
    nMinLenInt = 1   'the minimum integer part length
    nMaxLenInt = 4   'the maximum integer part length
    '--------------------------------------------------
    
    Randomize
    For r = LB1 To UB1
        For c = LB2 To UB2
            nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
            nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
            'make one random length integer string
            For n = 1 To nLenInt
                    If nLenInt = 1 Then                      'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    ElseIf nLenInt <> 1 And n = 1 Then       'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    Else
                        nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
                    End If
                    
                    sT1 = Chr$(nAsc)
                    sAccum1 = sAccum1 & sT1
                Next n
            'make one random length decimal part
            For n = 0 To nLenDecs
                nAsc = Int((57 - 48 + 1) * Rnd + 48)
                sT2 = Chr$(nAsc)
                sAccum2 = sAccum2 & sT2
            Next n
            'decide whether or not a negative number
            nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
            If nAsc = 5 Then sSign = "-" Else sSign = ""
            
            'store string
            If nLenDecs <> 0 Then
                vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
            Else
                vIn(r, c) = CSng(sSign & sAccum1)
            End If
                    
            sT1 = "": sT2 = ""
            sAccum1 = "": sAccum2 = ""
            'MsgBox vIn(r, c)
        Next c
    Next r
End Sub

Private Sub RndMixedDataToArr(vIn As Variant, nRows As Integer, nCols As Integer)
    'loads a 2D array in place with random string lengths
    
    Dim sAccum As String, nMinLenStr As Integer, sSign As String
    Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
    Dim nAsc As Integer, r As Long, c As Long, nMaxLenDec As Integer
    Dim sT As String, sT1 As String, sT2 As String, nMinLenDec As Integer
    Dim sAccum1 As String, sAccum2 As String, nMinLenInt As Integer
    Dim nLenInt As Integer, nLenDecs As Integer, nMaxLenInt As Integer
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
        
    '--------------------------------------------------
    'set user minimum and maximum settings here
    nMinLenStr = 3   'the minimum random text length
    nMaxLenStr = 8   'the maximum random text length
    nMinLenDec = 0   'the minumum decimal part length
    nMaxLenDec = 4   'the maximum decimal part length
    nMinLenInt = 1   'the minimum integer part length
    nMaxLenInt = 4   'the maximum integer part length
    '--------------------------------------------------
    
    Randomize
    For r = LB1 To UB1
        For c = LB2 To UB2
            If c Mod 2 <> 0 Then
                
                nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
                
                'make one random length string
                For n = 1 To nLenWord
                    nAsc = Int((90 - 65 + 1) * Rnd + 65)
                    sT = Chr$(nAsc)
                    sAccum = sAccum & sT
                Next n
                
                'store string
                vIn(r, c) = sAccum
                sAccum = "": sT = ""
            Else
                nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
                nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
                'make one random length integer string
                For n = 1 To nLenInt
                    If nLenInt = 1 Then                      'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    ElseIf nLenInt <> 1 And n = 1 Then       'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    Else
                        nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
                    End If
                    
                    sT1 = Chr$(nAsc)
                    sAccum1 = sAccum1 & sT1
                Next n
                'make one random length decimal part
                If nLenDecs <> 0 Then
                    For n = 1 To nLenDecs
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                        sT2 = Chr$(nAsc)
                        sAccum2 = sAccum2 & sT2
                    Next n
                Else
                        sAccum2 = ""
                End If
                'decide whether or not a negative number
                nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
                If nAsc = 5 Then sSign = "-" Else sSign = ""
                            
                'store string
                If nLenDecs <> 0 Then
                    vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
                Else
                    vIn(r, c) = CSng(sSign & sAccum1)
                End If
                        
                sT1 = "": sT2 = ""
                sAccum1 = "": sAccum2 = ""
            End If
        Next c
    Next r

End Sub

Sub testNumDecAlign()
    'produces examples in immediate window for single entries
    
    'clear the immediate window
    ClearImmWindow
    
    Debug.Print "|" & TabularAlignTxtOrNum(Cos(30), 3, 12) & "|"
    Debug.Print "|" & TabularAlignTxtOrNum("Text Heading", 3, 12) & "|"
    Debug.Print "|" & TabularAlignTxtOrNum(345.746453, 3, 12) & "|"
    Debug.Print "|" & TabularAlignTxtOrNum(56.5645, 0, 12) & "|"
    Debug.Print vbCrLf

End Sub

Private Function TabularAlignTxtOrNum(vIn As Variant, nNumDecs As Integer, _
                      nFieldWidth As Integer) As String
    'Notes:
    'Returns vIn in function name, formatted to given number of decimals,
    'and padded for display. VIn can contain an alpha string, a numeric
    'string, or a number. nNumDecs is intended number of decimals
    'in the output and nFieldWidth is its total padded width.
    'Non-numerics are left-aligned and numerics are right-aligned.
    'Decimal alignment results when say, all of an array column is
    'formatted with the same parameters.
    'ASSUMES THAT A MONOSPACED FONT WILL BE USED FOR DISPLAY
    
    Dim sPadding As String, sDecFormat As String
        
    'make a format based on whether numeric and how many decimals
    If IsNumeric(vIn) Then
        If nNumDecs > 0 Then                 'decimals
            sDecFormat = Format$(vIn, "0." & String$(nNumDecs, "0"))
        Else
            sDecFormat = Format$(vIn, "0") 'no decimals
        End If
    Else
            sDecFormat = vIn                 'non numeric
    End If
            
    'get a space string equal to max width
    sPadding = Space$(nFieldWidth)
    
    'combine and limit width
    If IsNumeric(vIn) Then
    'combine and limit width
        TabularAlignTxtOrNum = Right$(sPadding & sDecFormat, nFieldWidth)
    Else
        TabularAlignTxtOrNum = Left$(sDecFormat & sPadding, nFieldWidth)
    End If

End Function

Function WriteToFile(sIn As String, sPath As String) As Boolean
    'REPLACES all content of text file with parameter string
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim Number As Integer
    
    Number = FreeFile 'Get a file number
    
    'write string to file
    Open sPath For Output As #Number
    Print #Number, sIn
    Close #Number

    WriteToFile = True
    
End Function

See Also[edit | edit source]


Array Data To WorkSheet (1D or 2D)

Summary[edit | edit source]

This MS Excel VBA code listing transfers data from a one or two dimensional array to a worksheet.

Code Notes[edit | edit source]

  • Arr1Dor2DtoWorksheet() transfers data from an array to a specified worksheet, and at a specified location within it. It takes one-dimensional or two-dimensional arrays, and is able to distinguish between them, prior to the transfer. Non-array inputs are detected as are arrays that are not allocated. One-dimensional arrays are transferred into a sheet row in all cases. Two-dimensional arrays are displayed in the same row and column shape as in the array. There are no facilities in the procedure to transpose data, but procedures exist elsewhere in this series for that purpose.

The VBA Module[edit | edit source]

  • Copy the entire code listing into a VBA standard module and run the top procedure. Save the worksheet as type .xlsm. Comment and de-comment lines in the top procedure and adjust parameters to test the main procedure.
Sub TestArr1Dor2DtoWorksheet()

    Dim vB As Variant, vC As Variant, a() As String, sE As String
    Dim r As Long, c As Long, oSht As Worksheet
    
    'preliminaries
    Set oSht = ThisWorkbook.Worksheets("Sheet2")
    oSht.Activate
    oSht.Cells.Clear
    oSht.Cells(1, 1).Select
    
    'load a one dimensional array to test
    'vB = Array("a", "b", "c", "d") 'array and allocated one dimension
    vB = Split("A B C D E F G H I J K L M", " ")
    'load a two dimensional array to test
    ReDim vC(1 To 4, 1 To 4)
    For r = 1 To 3
        For c = 1 To 4
            vC(r, c) = CStr(r & "," & c)
        Next c
    Next r
    
    'Use these to test if input filters
    'Arr1Dor2DtoWorksheet sE, "Sheet2", 3, 3        'run to test not-an-array feature
    'Arr1Dor2DtoWorksheet a(), "Sheet2", 3, 3       'run to test not-allocated feature
    
    'print arrays on sheet
    Arr1Dor2DtoWorksheet vB, "Sheet2", 2, 2        '1D to sheet row
    Arr1Dor2DtoWorksheet vC, "Sheet2", 5, 2        '2D to sheet range

End Sub

Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _
                         ByVal nRow As Long, ByVal nCol As Long) As Boolean
    
    'Transfers a one or two dimensioned input array vA to the worksheet,
    'with top-left element at cell position nRow,nCol. sSht is the worksheet name.
    'Default 2D array transfers are made unchanged and a 1D array is displayed in a row.
            
    Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean
    Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long
    Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant
    
    'CHECK THE INPUT ARRAY
    On Error Resume Next
        'is it an array
        If IsArray(vA) = False Then
            bProb = True
        End If
        'check if allocated
        nR = UBound(vA, 1)
        If Err.Number <> 0 Then
            bProb = True
        End If
    Err.Clear
        
    If bProb = False Then
        'count dimensions
        On Error Resume Next
        Do
            nD = nD + 1
            nR = UBound(vA, nD)
        Loop Until Err.Number <> 0
    Else
        MsgBox "Parameter is not an array" & _
        vbCrLf & "or is unallocated - closing."
        Exit Function
    End If
    'get number of dimensions
    Err.Clear
    nDim = nD - 1: 'MsgBox nDim

    'get ref to worksheet
    Set oSht = ThisWorkbook.Worksheets(sSht)
       
    'set a worksheet range for array
    Select Case nDim
    Case 1 'one dimensional array
        LBR = LBound(vA): UBR = UBound(vA)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR))
    Case 2 'two dimensional array
        LBR = LBound(vA, 1): UBR = UBound(vA, 1)
        LBC = LBound(vA, 2): UBC = UBound(vA, 2)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC))
    Case Else 'unable to print more dimensions
        MsgBox "Too many dimensions - closing"
        Exit Function
    End Select

    'transfer array values to worksheet
        rng.Value = vA
    
    'release object variables
    Set oSht = Nothing
    Set rng = Nothing
    
    'returns
    Arr1Dor2DtoWorksheet = True

End Function

See Also[edit | edit source]


Array Output Transfers

Summary[edit | edit source]

This VBA code module demonstrates four basic methods of array display. It is intended to run in MS Excel, though with the exception of the first method, transfer to the worksheet, it could be adapted easily for MS Word or other MS Office applications that run VBA.

Code Notes[edit | edit source]

  • The code first loads an array with selected random data. Then the entire array is transferred to the worksheet. The data is further formatted and displayed in the immediate window, in well spaced columns. An additional copy of the formatted output is passed to the clipboard for further external use, and it is also sent to a text file to illustrate the method.
  • RndDataToArr() can load an array with random data. The data types can be set as parameters, and further limits can be found within the procedure itself. Alpha, integer, decimal, dates, and mixed data are available, most random in both length and content.
  • Arr1Dor2DtoWorksheet() can transfer either a one-dimensional or two dimensional array to a worksheet. It can be positioned at any location. It checks that an array exists,that it is allocated, and its number of dimensions in setting the transfer range.
  • DispArrInImmWindow() formats and displays a 2D array in the immediate window of the VBA editor. It takes account of all data length in setting the well aligned columns. There are parameters to set maximum decimal places and the choice of decimal point alignment or raw data. The layout can handle mixed columns of text and numbers, though it has best appearance when all data of a column is of the same type. The whole array's formatted output is available as a single string for external use, useful for arrays beyond 199 rows, as too big for the immediate window.
  • CopyToClip() is used to pass a string to the clipboard. It is used here to upload the formatted array string. The clipboard will retain the contents only until the calling application (Excel) closes. It should be noted that other clipboard procedures in this series retain their content until the Windows platform closes.
  • GetFromClip() retrieves the contents of the clipboard. It is used here purely for demonstration. It passes the entire formatted string of the array to a text file.
  • WriteToFile() opens and writes to a named text file. It completely replaces any text that it already contains. If the file does not exist the procedure makes it, in the same directory as the Excel file itself.

The VBA Code Module[edit | edit source]

Copy the entire code listing into an Excel VBA module, and run the top procedure to test the four array transfer methods. Save the file as type xlsm. The code writes to Sheet1, and to the immediate window of the VBA editor. Further array listings will be found on the clipboard and in a text file made for the purpose.

Option Explicit
Private Sub ArrayOutputTests()
    ' Test procedure for array display
    '1 array to worksheet
    '2 formatted array to immediate window
    '3 formatted array to clipboard
    '4 formatted array to text file

    Dim vA As Variant, vB As Variant
    Dim sArr As String, oSht As Worksheet
    Dim sIn As String, sOut As String, sSheet As String
    
    '-------------------------------------------
    'choose worksheet for display
    '-------------------------------------------
    
        sSheet = "Sheet1"
        Set oSht = ThisWorkbook.Worksheets(sSheet)
    
    '-------------------------------------------
    'load an array to test
    '-------------------------------------------
        
        RndDataToArr vA, 16, 10, "mixed"
        vB = vA
    
    '-------------------------------------------
    'array to the worksheet
    '-------------------------------------------
        
        'clear the worksheet
        oSht.Cells.Clear
        
        'transfer array
        Arr1Dor2DtoWorksheet vA, "Sheet1", 1, 1
        
        'format columns of the sheet
        With oSht.Cells
            .Columns.AutoFit
            .NumberFormat = "General"
            .NumberFormat = "0.000" 'two decimals
        End With
    
    '-------------------------------------------
    'array formatted and to the immediate window
    '-------------------------------------------
        
        'clear the immediate window
        ClearImmWindow
        
        'formatted array to immediate window
        DispArrInImmWindow vB, True, 3, sIn
    
        'get formatted array string for further use
        sArr = sIn
    
    '--------------------------------------------
    'array formatted and to the clipboard
    '--------------------------------------------
        
        'formatted array string to clipboard
        CopyToClip sArr
    
    '--------------------------------------------
    'array formatted and to a text file or log
    '--------------------------------------------
        
        'retrieve clipboard string
        sOut = GetFromClip
    
        'formatted array string replaces text file content
        WriteToFile sOut, ThisWorkbook.Path & "\MyLongArray.txt"
    
    '---------------------------------------------
    'release object variables
    '---------------------------------------------
        
        Set oSht = Nothing
    
End Sub

Private Sub RndDataToArr(vIn As Variant, nRows As Integer, nCols As Integer, sType As String)
    'Loads a 2D array in place with a choice of random alpha strings
    'numbers or dates.
    
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    Dim nMinLenStr As Integer, nMaxLenStr As Integer
    Dim nMinLenDec As Integer, nMaxLenDec As Integer
    Dim nMinLenInt As Integer, nMaxLenInt As Integer
    Dim LA As Integer, LI As Integer, sT As String, sT2 As String
    Dim sAccum As String, sAccum1 As String, sAccum2 As String
    Dim nDec As Single, LD As Integer, nS As Integer, sDF As String
    Dim sAlpha As String, sInteger As String, sDecimal As String
    Dim r As Long, c As Long, bIncMinus As String, bNeg As Boolean
    Dim dMinDate As Date, dMaxDate As Date, nD As Long
    
    '------------------------------------------------------------------------
    'Parameter Notes:
    'sType sets the type of data to load into the array.
    '   "Alpha" loads random length strings of capitals - length set below
    '   "Integer" loads random length integers - length set below
    '   "Decimal" loads random integer and decimal parts - length set below
    '   "Dates"   loads random dates throughout - range set below
    '   "Mixed" loads alternate columns of alpha and decimal data - set below
    'nRows is the number of required array rows
    'nCols is the number of required array columns
    'vIn contains the input array
    '------------------------------------------------------------------------
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
        
    '--------------------------------------------------
    'set user minimum and maximum settings here
    nMinLenStr = 3   'the minimum random text length
    nMaxLenStr = 8   'the maximum random text length
    nMinLenDec = 1   'the minumum decimal part length
    nMaxLenDec = 3   'the maximum decimal part length
    nMinLenInt = 1   'the minimum integer part length
    nMaxLenInt = 5   'the maximum integer part length
    dMinDate = #1/1/1900#     'earliest date to list
    dMaxDate = Date              'latest date to list
    sDF = "dddd, mmm d yyyy"      'random date format
    bIncMinus = True      'include random minus signs
    '--------------------------------------------------
    
    'randomize using system timer
    Randomize
          
    For r = LB1 To UB1
        For c = LB2 To UB2
            
            'get random lengths of elements
            Select Case LCase(sType)
            Case "alpha"
                LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
            Case "integer"
                LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
            Case "decimal"
                LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
                LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
            Case "mixed"
                LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
                LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
                LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
            Case "dates"
            End Select
                    
            'make an alpha string
            Do
                sT = Chr$(Int((90 - 65 + 1) * Rnd + 65))
                sAccum = sAccum & sT
            Loop Until Len(sAccum) >= LA
            sAlpha = sAccum
            sAccum = "": sT = ""
                            
            'make an integer
            Do
                If LI = 1 Then 'zero permitted
                    sT = Chr$(Int((57 - 48 + 1) * Rnd + 48))
                    sAccum = sAccum & sT
                ElseIf LI > 1 And Len(sAccum) = 0 Then 'zero not permitted
                    sT = Chr$(Int((57 - 49 + 1) * Rnd + 49))
                    sAccum = sAccum & sT
                Else
                    sT = Chr$(Int((57 - 48 + 1) * Rnd + 48))
                    sAccum = sAccum & sT
                End If
            Loop Until Len(sAccum) >= LI
            sInteger = sAccum
            sAccum = "": sT = ""
                                       
            'make a decimal part
            Do
                sT2 = Chr$(Int((57 - 48 + 1) * Rnd + 48))
                sAccum2 = sAccum2 & sT2
            Loop Until Len(sAccum2) >= LD
            sDecimal = sAccum2
            sAccum = "": sAccum2 = "": sT2 = ""
                       
            'decide proportion of negative numbers
            nS = Int((3 - 0 + 1) * Rnd + 0)
            If nS = 1 And bIncMinus = True Then
                sInteger = "-" & sInteger
            End If
                            
            'assign value to array element
            Select Case LCase(sType)
            Case "alpha"
                vIn(r, c) = sAlpha
            Case "integer"
                vIn(r, c) = CLng(sInteger)
            Case "decimal"
                vIn(r, c) = CSng(sInteger & "." & sDecimal)
            Case "dates"
                nD = WorksheetFunction.RandBetween(dMinDate, dMaxDate)
                vIn(r, c) = Format(nD, sDF)
            Case "mixed"
                If c Mod 2 = 0 Then 'alternate columns alpha and decimal
                    vIn(r, c) = CSng(sInteger & "." & sDecimal)
                Else
                    vIn(r, c) = sAlpha
                End If
            End Select
        Next c
    Next r
End Sub

Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _
                         ByVal nRow As Long, ByVal nCol As Long) As Boolean
    
    'Transfers a one or two dimensioned input array vA to the worksheet,
    'with top-left element at cell position nRow,nCol. sSht is the worksheet name.
    'Default 2D array transfers are made unchanged and a 1D array is displayed in a row.
            
    Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean
    Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long
    Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant
    
    'CHECK THE INPUT ARRAY
    On Error Resume Next
        'is it an array
        If IsArray(vA) = False Then
            bProb = True
        End If
        'check if allocated
        nR = UBound(vA, 1)
        If Err.Number <> 0 Then
            bProb = True
        End If
    Err.Clear
        
    If bProb = False Then
        'count dimensions
        On Error Resume Next
        Do
            nD = nD + 1
            nR = UBound(vA, nD)
        Loop Until Err.Number <> 0
    Else
        MsgBox "Parameter is not an array" & _
        vbCrLf & "or is unallocated - closing."
        Exit Function
    End If
    'get number of dimensions
    Err.Clear
    nDim = nD - 1: 'MsgBox nDim

    'get ref to worksheet
    Set oSht = ThisWorkbook.Worksheets(sSht)
       
    'set a worksheet range for array
    Select Case nDim
    Case 1 'one dimensional array
        LBR = LBound(vA): UBR = UBound(vA)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR))
    Case 2 'two dimensional array
        LBR = LBound(vA, 1): UBR = UBound(vA, 1)
        LBC = LBound(vA, 2): UBC = UBound(vA, 2)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC))
    Case Else 'unable to print more dimensions
        MsgBox "Too many dimensions - closing"
        Exit Function
    End Select

    'transfer array values to worksheet
        rng.Value = vA
    
    'release object variables
    Set oSht = Nothing
    Set rng = Nothing
    
    'returns
    Arr1Dor2DtoWorksheet = True

End Function

Private Sub ClearImmWindow()
    
    'NOTES
    'Clears VBA immediate window down to the insertion point,
    'but not beyond. Not a problem as long as cursor is
    'at end of text, but otherwise not.
    'Clear manually before any neat work.
    'Manual clear method: Ctrl-G then Ctrl-A then Delete.
    
    'Max display in immediate window is 199 lines,
    'then top lines are lost as new ones added at bottom.
    'No reliable code method exists.
    
    Debug.Print String(200, vbCrLf)
    
End Sub

Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
                                  Optional ByVal nNumDecs As Integer = 2, _
                                     Optional sOut As String)

    '--------------------------------------------------------------------------
    'vA :               Input 2D array for display in the immediate window.
    'sOut:              Alternative formatted output string.
    'bFormatAlignData : True: applies decimal rounding and decimal alignment,
    '                   False: data untouched with only basic column spacing.
    'nNumDecs:          Sets the rounding up and down of decimal places.
    '                   Integers do not have zeros added at any time.
    'Clear the immediate window before each run for best results.
    'The immediate window at best lists 199 lines before overwrite, so
    'consider using sOut for large arrays.  'ie; use it in a text file
    'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
    'so set the font VBA editor or any textbox to Courier or Consolas.
    'To set different formats for EVERY column of an array it is best to add
    'the formats at loading time with the procedure TabularAlignTxtOrNumber().
    '--------------------------------------------------------------------------
    
    'messy when integers are set in array and decimals is set say to 3.
    'maybe the measurement of max element width should include a measure
    ' for any dot or extra imposed decimal places as well
    'different for integers and for existing decimals
        
    Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
    Dim sPadding As String, sDecFormat As String, sR As String, sE As String
    Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
    Dim nMaxFieldWidth As Integer, bSkip As Boolean
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    'get bounds of input array
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
    
    ReDim vD(LB1 To UB1, LB2 To UB2) 'display
    ReDim vC(LB2 To UB2)             'column max
    
    '--------------------------------------
    'set distance between fixed width
    'fields in the output display
    nInterFieldSpace = 3
    'not now used
    nMaxFieldWidth = 14
    '--------------------------------------
    
    If nNumDecs < 0 Then
        MsgBox "nNumDecs parameter must not be negative - closing"
        Exit Sub
    End If
        
    'find widest element in each column
    'and adjust it for any imposed decimal places
    For c = LB2 To UB2
        n = 0: m = 0
        For r = LB1 To UB1
            'get element length
            If IsNumeric(vA(r, c)) Then
                If Int(vA(r, c)) = vA(r, c) Then 'is integer
                    n = Len(vA(r, c)) + 1 + nNumDecs
                Else 'is not integer
                    If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
                        n = Len(vA(r, c))
                    Else  'add the difference in length as result of imposed decimal places
                        n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
                    End If
                End If
            Else
                n = Len(vA(r, c))
            End If
            
            If n > m Then m = n 'update if longer
        Next r
        'store the maximum length
        'of data in each column
        vC(c) = m
    Next c
        
    For c = LB2 To UB2
        For r = LB1 To UB1
            sE = Trim(vA(r, c))

            If bFormatAlignData = False Then
                sDecFormat = sE
                nP = InStr(sE, ".")
                bSkip = True
            End If

            'make a basic format
            If bSkip = False Then
                nP = InStr(sE, ".")
                'numeric with a decimal point
                If IsNumeric(sE) = True And nP > 0 Then
                    sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
                'integer
                ElseIf IsNumeric(sE) = True And nP <= 0 Then
                    sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
                'alpha
                ElseIf IsNumeric(sE) = False Then
                    sDecFormat = sE
                End If
            End If
  
            'adjust field width to widest in column
            bSkip = False
            sPadding = Space$(vC(c))
            'numeric with a decimal point
            If IsNumeric(sE) = True And nP > 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'integer
            ElseIf IsNumeric(sE) = True And nP <= 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'alpha
            ElseIf IsNumeric(sE) = False Then
                vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
            End If
        Next r
    Next c
        
    'output
    sOut = ""
    For r = LB1 To UB1
        For c = LB2 To UB2
            sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
        Next c
        Debug.Print sR             'print one row in imm window
        sOut = sOut & sR & vbCrLf  'accum one row in output string
        sR = ""
    Next r
    sOut = sOut & vbCrLf
    Debug.Print vbCrLf

End Sub

Private Function CopyToClip(sIn As String) As Boolean
    'passes the parameter string to the clipboard
    'set reference to Microsoft Forms 2.0 Object Library.
    'Clipboard cleared when launch application closes.
    
    Dim DataOut As DataObject
    
    Set DataOut = New DataObject
    
    'first pass textbox text to dataobject
    DataOut.SetText sIn
    
    'then pass dataobject text to clipboard
    DataOut.PutInClipboard
    
    'release object variable
    Set DataOut = Nothing
    
    CopyToClip = True
    
End Function

Private Function GetFromClip() As String
    'passes clipboard text to function name
    'If clipboard not text, an error results
    'set reference to Microsoft Forms 2.0 Object Library.
    'Clipboard cleared when launch application closes.
    
    Dim DataIn As DataObject
    
    Set DataIn = New DataObject
    
    'clipboard text to dataobject
    DataIn.GetFromClipboard
    
    'dataobject text to function string
    GetFromClip = DataIn.GetText
    
    'release object variable
    Set DataIn = Nothing
    
End Function

Private Function WriteToFile(sIn As String, sPath As String) As Boolean
    'REPLACES all content of text file with parameter string
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim Number As Integer
    
    Number = FreeFile 'Get a file number
    
    'write string to file
    Open sPath For Output As #Number
    Print #Number, sIn
    Close #Number

    WriteToFile = True
    
End Function

See Also[edit | edit source]


Charts from Arrays

Summary[edit | edit source]

Charts can be either embedded, where they are found in association with worksheets, or can occupy sheets of their own. The code example below makes basic charts on their own sheets. Purely to test the code, there is a procedure to fetch a selection of cells from the worksheet. Clearly, this procedure is justified only for testing since there are easier ways to make charts starting from a selection of cells. Array charting is generally most useful when data is not first written to a worksheet.

The chart procedure runs from an array. The array can contain one X series, and any practical number of Y series. However, the layout of the array is strict; the first row must contain only X data. All other rows will be treated as having Y series data in them. No heading labels can be included.

If the source data has its series in columns instead of the rows required by the chart array, then the data is transposed before the charting point. A transpose procedure is included in the code.

The code can be tested as a self-contained standard module.

The VBA Code[edit | edit source]

Because there are too many variations of chart types to accommodate with any accuracy, only the most general properties can be considered in one procedure. As a result, the user should add any specific code to the appropriate sections.

Note that in the supporting procedures, both empty selections and insufficient selections generate errors, so a minimal error handling was added.

Option Explicit

Sub ChartFromSelection()
    'select a block of cells to chart - then run;
    'either; top row X data, and all other rows Y series, or
    'first column X data, and all columns Y series;
    'set boolean variable bSeriesInColumns to identify which:
    'Do not include heading labels in the selection.
    
    Dim vA As Variant, bOK1 As Boolean, bOK2 As Boolean
    Dim bTranspose As Boolean, bSeriesInColumns As Boolean
    
    'avoid errors for 'no selection'
    On Error GoTo ERR_HANDLER
        
    'set for series in rows (True), or in columns (False)
    bSeriesInColumns = False
    
    'load selection into array
    LoadArrSelectedRange vA, bSeriesInColumns
    
    'make specified chart type
    ChartFromArray vA, xlLine
    
    'advise complete
    MsgBox "Chart done!"
    ActiveChart.ChartArea.Activate
    Exit Sub

ERR_HANDLER:
    Select Case Err.Number
        Case 13 'no selection made
            Err.Clear
            MsgBox "Make a 2D selection of cells"
            Exit Sub
        Case Else
            Resume Next
    End Select

End Sub

Public Function LoadArrSelectedRange(vR As Variant, Optional bTranspose As Boolean = False) As Boolean
    'gets the current selection of cells - at least 2 cols and 2 rows, ie, 2 x 2
    'and returns data array in vR
    'if bTranspose=True then selection is transposed before loading array
    'before array storage - otherwise as found
    
    Dim vA As Variant, rng As Range
    Dim sht As Worksheet, vT As Variant
    Dim r As Long, c As Long
    Dim lb1, ub1, lb2, ub2
    Dim nSR As Long, nSC As Long
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    
    'make sure a range is selected
    If TypeName(Selection) <> "Range" Then Exit Function
    
    'find bounds of selection
    With Application.Selection
        nSR = .Rows.Count
        nSC = .Columns.Count
    End With
    
    'check that enough data is selected
    If nSC < 2 Or nSR < 2 Then
        MsgBox "No useful selection was found." & vbCrLf & _
               "Needs at least two rows and two columns" & vbCrLf & _
               "for array 2D loading."
        Exit Function
    End If
    
    'dimension work array
    ReDim vA(1 To nSR, 1 To nSC)
        
    'get range of current selection
    Set rng = Application.Selection
        
    'pass range of cells to array
    vA = rng
    
    'output transposed or as found
    If bTranspose = True Then
        TransposeArr2D vA, vT
        vR = vT
    Else
        vR = vA
    End If
        
    'collapse selection to top left
    sht.Cells(1, 1).Select
    
    'transfers
    LoadArrSelectedRange = True

End Function

Function ChartFromArray(ByVal vA As Variant, Optional vChartType As Variant = xlLine) As Boolean
    'assumes multi series are in array ROWS
    'if data in columns then transpose it before call
    'at this point vA must have X values in first row
    'and all other rows assumed to be Y series
    'only data - no label columns
    
    'Chart type notes
    '================================
    'xlArea,
    'xlBarClustered
    'xlLine, xlLineMarkers
    'xlXYScatter, xlXYScatterLines
    'xlPie, xlPieExploded
    'xlRadar, xlRadarMarkers
    'xlSurface, xlSurfaceTopView
    'see link in ChartType help page
    'for full list of chart types
    '================================
    
    Dim lb1 As Long, ub1 As Long, lb2 As Long, ub2 As Long
    Dim X As Variant, Y As Variant, oChrt As Chart
    Dim n As Long, m As Long, S As Series, bTrimAxes As Boolean
    Dim sT As String, sX As String, sY As String
    
    'set axes labels
    sT = "Top Label for Chart Here"
    sX = "X-Axis Label Here"
    sY = "Y-Axis Label Here"
    
    'set boolean to True to enable axes trimming code block
    bTrimAxes = False
    
    'get bounds of array
    lb1 = LBound(vA, 1): ub1 = UBound(vA, 1)
    lb2 = LBound(vA, 2): ub2 = UBound(vA, 2)
    
    
    ReDim X(lb2 To ub2) '1 to 11 data
    ReDim Y(lb2 To ub2) '1 to 11 data

    'make a chart
    Set oChrt = Charts.Add
        
    'use parameter chart type
    oChrt.ChartType = vChartType
    
    'load the single X series
    For n = lb2 To ub2
        X(n) = vA(lb1, n)
    Next n
        
    'remove unwanted series
    With oChrt
        Do Until .SeriesCollection.Count = 0
            .SeriesCollection(1).Delete
        Loop
    End With
    
    'add the intended series
    For m = 2 To ub1
        'load one Y series at a time
        For n = lb2 To ub2
            Y(n) = vA(m, n)
        Next n
                
        'make new series object
        Set S = ActiveChart.SeriesCollection.NewSeries
        
        'transfer series individually
        With S
            .XValues = X
            .Values = Y
            .Name = "Series names"
        End With
    Next m
        
    'APPLY ALL OTHER CHART PROPERTIES HERE
    On Error Resume Next 'avoid display exceptions
        With oChrt
          'CHART-SPECIFIC PROPERTIES GO HERE
            Select Case .ChartType
                Case xlXYScatter
                Case xlLine
                Case xlPie
                Case xlRadar
                Case xlSurface
            End Select
            
          'GENERAL CHART PROPERTIES GO HERE
            'labels for the axes
            .HasTitle = True
            .ChartTitle.Text = sT 'chart title
            .SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
            .Axes(xlCategory).AxisTitle.Text = sX 'X
            .SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
            .Axes(xlValue).AxisTitle.Text = sY    'Y
            .Legend.Delete
        
            If bTrimAxes = True Then
                'X Axis limits and such- set as required
                .Axes(xlCategory).Select
                .Axes(xlCategory).MinimumScale = 0
                .Axes(xlCategory).MaximumScale = 1000
                .Axes(xlCategory).MajorUnit = 500
                .Axes(xlCategory).MinorUnit = 100
                Selection.TickLabelPosition = xlLow
        
                'Y Axis limits and such- set as required
                .Axes(xlValue).Select
                .Axes(xlValue).MinimumScale = -0.2
                .Axes(xlValue).MaximumScale = 1.2
                .Axes(xlValue).MajorUnit = 0.1
                .Axes(xlValue).MinorUnit = 0.05
             End If
        End With
    On Error GoTo 0
    oChrt.ChartArea.Select
    Set oChrt = Nothing
    Set S = Nothing
    
    ChartFromArray = True
    
End Function

Function TransposeArr2D(vA As Variant, Optional vR As Variant) As Boolean
        
    '---------------------------------------------------------------------------------
    ' Procedure : Transpose2DArr
    ' Purpose   : Transposes a 2D array; rows become columns, columns become rows
    '             Specifically, (r,c) is moved to (c,r) in every case.
    '             Options include, returned in-place with the source changed, or
    '             if vR is supplied, returned in that instead, with the source intact.
    '---------------------------------------------------------------------------------
    
    Dim vW As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim r As Long, c As Long, bWasMissing As Boolean
    
    'find whether optional vR was initially missing
    bWasMissing = IsMissing(vR)
    If Not bWasMissing Then Set vR = Nothing
    
    'use a work array
    vW = vA
    
    'find bounds of vW data input work array
    loR = LBound(vW, 1): hiR = UBound(vW, 1)
    loC = LBound(vW, 2): hiC = UBound(vW, 2)
    
    'set vR dimensions transposed
    'Erase vR 'there must be an array in the variant to erase
    ReDim vR(loC To hiC, loR To hiR)
    
    'transfer data
    For r = loR To hiR
        For c = loC To hiC
            'transpose vW into vR
            vR(c, r) = vW(r, c)
        Next c
    Next r
    
    'find bounds of vW data input work array
'    loR = LBound(vR, 1): hiR = UBound(vR, 2)
'    loC = LBound(vR, 2): hiC = UBound(vR, 2)


TRANSFERS:
    'decide whether to return in vA or vR
    If Not bWasMissing Then
        'vR was the intended return array
        'so leave vR as it is
    Else:
        'vR is not intended return array
        'so reload vA with vR
        vA = vR
    End If
    
    'return success for function
    TransposeArr2D = True
    
End Function

Sub LoadArrayTestData()
    'loads an array with sample number data
    'first row values of x 1 to 100
    'next three rows y series
    
    Dim nNS As Long, f1 As Single
    Dim f2 As Single, f3 As Single
    Dim vS As Variant, vR As Variant, n As Long
    
    'dimension work array
    nNS = 50
    ReDim vS(1 To 4, 1 To nNS)
    
    'make function loop
    For n = 1 To nNS
        f1 = (n ^ 1.37 - 5 * n + 1.5) / -40
        On Error Resume Next
        f2 = Sin(n / 3) / (n / 3)
        f3 = 0.015 * n + 0.25
        vS(1, n) = n  'X
        vS(2, n) = f1 'Y1
        vS(3, n) = f2 'Y2
        vS(4, n) = f3 'Y3
    Next n
    
    ChartFromArray vS, xlLine

End Sub

Sub DeleteAllCharts6()
    'run this to delete all ThisWorkbook charts
    
    Dim oC
       
    Application.DisplayAlerts = False
    
    For Each oC In ThisWorkbook.Charts
        oC.Delete
    Next oC
    
    Application.DisplayAlerts = True
    
End Sub


Character Frequency Charts in Excel

Summary[edit | edit source]

VBA Code Listings[edit | edit source]

At times it is useful to make an Excel chart from VBA. The code below makes a frequency bar chart based on a given string. It is shown in testing mode with a random string input. The user should replace that string with his own. There are various charting options.

Option Explicit

Sub Test()
    'run this to test the charting of this module
    
    Dim str As String, n As Long
    
    'make random mixed characters (for testing only)
    str = MakeLongMixedString(10000)
    
    'make a sorted frequency chart of the characters in str
    MakeCharaFreqChart str, 1, "n"
    
    MsgBox "Chart done"
    
End Sub

Function MakeLongMixedString(nNumChr As Long) As String
    'Makes a long capital letters string using rnd VBA function
    
    Dim n As Long, sChr As String, nAsc As Long
    Dim nSamp As Long, sAccum As String, c As Long
    
    '========================================================================
    ' Notes and Conclusions:
    ' The VBA function rnd is UNSUITED to generation of long random strings.
    ' Both length and number of repeats increases rapidly near 256 charas.
    ' Reasonable results can be obtained by keeping below 128 characters.
    ' For longer strings, consider hash-based methods of generation.
    '========================================================================
        
    Do Until c >= nNumChr
        DoEvents
        Randomize
        'A to Z corresponds to asci 65 to 90
        nSamp = Int((90 - 48 + 1) * Rnd + 48)
        If (nSamp >= 48 And nSamp <= 57) Or (nSamp >= 65 And nSamp <= 90) Then
           sChr = Chr(nSamp)
           sAccum = sAccum & sChr
           c = c + 1
        End If
    Loop
    
    'MsgBox sAccum
    
    MakeLongMixedString = sAccum

End Function

Sub MakeCharaFreqChart(str As String, bSort As Boolean, sYUnits As String)
    'For use in Excel
    'makes a character frequency chart using the parameter string str
    'bSort=True to sort the chart from highest (left) otherwise unsorted
    'sYUnits string sets measurement method, number charas, percentage total, or normalised to max value
    
    Dim vC As Variant, nRow As Long, vRet As Variant
    
    GetCharaCounts str, vC
    
    Select Case LCase(sYUnits)
    Case "n", "numbers", "number", "count", "#"
        nRow = 1
    Case "p", "percent", "percentage", "%"
        nRow = 2
    Case "r", "relative", "normalized", "normalised"
        nRow = 3
    End Select
    
    If bSort Then
        SortColumns vC, 1, 0, vRet
        ChartColumns vRet, 1, 0, nRow, 1, "Selective Distribution of a " & Len(str) & " Character String", _
        "Character Set of Interest", "Number of Each"
    Else
        ChartColumns vC, 1, 0, nRow, 1, "Selective Distribution of a " & Len(str) & " Character String", _
        "Character Set of Interest", "Number of Each"
    End If
    
End Sub

Sub GetCharaCounts(sIn As String, vR As Variant)
    'loads an array with character counts
    
    Dim vRef As Variant, LBC As Long, UBC As Long, LBR As Long, UBR As Long
    Dim vW() As Variant, X() As Variant, Y() As Variant, vRet As Variant
    Dim sUC As String, nC As Long, n As Long, sS As String, ValMax As Variant
    
    'Notes for vR and vW loads
    'Row 0: the ref chara set from vRef
    'Row 1: the number of hits found in str for each chara in ref set
    'Row 2: the percentage that hits rep of total charas in str
    'Row 3: the normalized values for each chara with max as unity
    
    If sIn = "" Then
        MsgBox "Empty input string - closing"
        Exit Sub
    End If
    
    'load the intended x-axis display set here...add to it or subtract as required
    vRef = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
    "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
    "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")       ' ,"(", ")", ":", ".", ",")
    
    LBC = LBound(vRef): UBC = UBound(vRef)
    ReDim vW(0 To 3, LBC To UBC)
    LBR = LBound(vW, 1): UBR = UBound(vW, 1)
    ReDim X(LBC To UBC)
    ReDim Y(LBC To UBC)
    
    sUC = UCase(sIn)
    nC = Len(sIn)
    For n = LBC To UBC
        vW(0, n) = vRef(n) 'all charas to first row
        sS = vW(0, n)
        'count hits in string for each chara in ref set
        vW(1, n) = UBound(Split(sUC, sS)) - LBound(Split(sUC, sS)) 'count hits
        'calculate hits as percentages of total chara count
        vW(2, n) = Round(((vW(1, n)) * 100 / nC), 1)
    Next n
    
    'find max value in array count
    SortColumns vW, 1, False, vRet
    ValMax = vRet(1, 0)
    
    'normalize to unity as max value
    For n = LBC To UBC
        vW(3, n) = Round(vW(1, n) / ValMax, 1)
    Next n
    
    vR = vW()
    
End Sub

Sub ChartColumns(ByVal VA As Variant, bColChart As Boolean, RowX As Long, RowY As Long, _
    Optional bXValueLabels As Boolean = 0, Optional sTitle As String = "", _
    Optional sXAxis As String, Optional sYAxis As String)
    'this is the actual chart procedure. It charts the array data in VA 
    'the array must contain two data rows for the chart; with x and y data
    'the chart can be column or scatter chart; RowX and RowY parameters identify the data rows for each axis.
    'optional parameters are included for value labels, chart title, x axis label, and y axis label
    
    Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long, n As Long
    Dim X As Variant, Y As Variant, sX As String, sY As String, sT As String, oC As Chart
    
    LBR = LBound(VA, 1): UBR = UBound(VA, 1)
    LBC = LBound(VA, 2): UBC = UBound(VA, 2)
    ReDim X(LBC To UBC)
    ReDim Y(LBC To UBC)
    
    'labels for specific charts
    If sTitle = "" Then sT = "Title Goes Here" Else sT = sTitle
    If sXAxis = "" Then sX = "X Axis Label Goes Here" Else sX = sXAxis
    If sYAxis = "" Then sY = "Y Axis Label Goes Here" Else sY = sYAxis
    
    If RowX < LBR Or RowX > UBR Or RowY < LBC Or RowY > UBC Then
        MsgBox "Parameter data rows out of range in ChartColumns - closing"
        Exit Sub
    End If
    
    'transfer data to chart arrays
    For n = LBC To UBC
        X(n) = VA(RowX, n) 'x axis data
        Y(n) = VA(RowY, n) 'y axis data
    Next n
    
    'make chart
    Charts.Add
    
    'choose a column chart or a scatter chart
    If bColChart Then
        ActiveChart.ChartType = xlColumnClustered 'column chart
    Else
        ActiveChart.ChartType = xlXYScatterLinesNoMarkers 'line scatter chart
        'ActiveChart.ChartType = xlXYScatter 'point scatter chart
End If
    
    'assign the data and labels to a series
    With ActiveChart.SeriesCollection
        If .Count = 0 Then .NewSeries
            If bXValueLabels And bColChart Then
                .Item(1).ApplyDataLabels Type:=xlDataLabelsShowValue
                'item(1).DataLabels.Orientation = xlUpward
                .Item(1).DataLabels.Orientation = 60
            End If
            If Val(Application.Version) >= 12 Then
                .Item(1).Values = Y
                .Item(1).XValues = X
            Else
                .Item(1).Select
                Names.Add "_", X
                ExecuteExcel4Macro "series.x(!_)"
                Names.Add "_", Y
                ExecuteExcel4Macro "series.y(,!_)"
                Names("_").Delete
            End If
        End With
        
        'apply title string, x and y axis strings, and delete legend
        With ActiveChart
            .HasTitle = True
            .ChartTitle.Text = sT
            .SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
            .Axes(xlCategory).AxisTitle.Text = sX
            .SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
            .Axes(xlValue).AxisTitle.Text = sY
            .Legend.Delete
        End With
        
        ActiveChart.ChartArea.Select
    
End Sub

Sub SortColumns(ByVal VA As Variant, nRow As Long, bAscend As Boolean, vRet As Variant)
    'bubblesorts the input array's columns using values in the specified row, ascending or descending, ret in vRet
    
    Dim i As Long, j As Long, bCond As Boolean, Y As Long, t As Variant
    Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long
    
    LBR = LBound(VA, 1): UBR = UBound(VA, 1)
    LBC = LBound(VA, 2): UBC = UBound(VA, 2)
    
    For i = LBC To UBC - 1
        For j = LBC To UBC - 1
            If bAscend Then
                bCond = VA(nRow, j) > VA(nRow, j + 1)
            Else
                bCond = VA(nRow, j) < VA(nRow, j + 1)
            End If
            If bCond Then
                For Y = LBR To UBR
                    t = VA(Y, j)
                    VA(Y, j) = VA(Y, j + 1)
                    VA(Y, j + 1) = t
                Next Y
            End If
        Next j
    Next i
    
    vRet = VA
    
End Sub

Sub DeleteAllWorkbookCharts()
    'run this manually to delete all charts
    'not at this stage called in any procedure
        
    Dim oC
    
    Application.DisplayAlerts = False
    For Each oC In ThisWorkbook.Charts
        oC.Delete
    Next oC
    Application.DisplayAlerts = True
    
End Sub


Clipboard VBA

Summary[edit | edit source]

There are three main ways to pass text to and from the clipboard with VBA code.

  • The DataObject method:
    • This is perhaps the simplest implementation.
    • Its main restriction is that the contents of the clipboard will be lost when the launching application is closed; generally this is not a problem when running Excel modules, but should be borne in mind.
    • Some users elsewhere report bugs. See DataObject Bugs Forum for details of the bugs and one suggested fix. All of the procedures on this page are tested and work well in both Windows 7 and Windows 8.1 for Excel 2010. The DataObject method has recently been adopted for the VBA Indenter module, in this same series.
    • Other methods avoid these restrictions. In the unlikely event of problems with these procedures, either of the next two methods would suffice.
    • An example of the DataObject method is given in section two of this page.
  • User form control methods:
    • When user forms are to be displayed, then the copy and paste methods of the text box can be used. These methods work well and are well tested.
    • When no user form is to be displayed, a hidden form can be used. The form with a text box, is loaded but never displayed. Then, the invisible user form's controls can still then be coded as normal. The text box must have its Multiline property set to true for most useful text transfers. It will be found best, in general,to set the form's ShowModal property to False; this allows for convenient code tracing and avoids many other confusions.
    • An example of the hidden user form method is given in section four. Another example in section three, for a visible user form, shows how to track the active text box prior to copy.
  • API methods:
    • These methods make use of Windows libraries, and have copious declarations in their module headings. That said, they work well, and are described by Microsoft documentation as being the most suitable.
    • One example of API use is displayed in section five. See Send-Information-to-the-Clipboard for more details.

DataObject Method[edit | edit source]

  • These methods make used of a DataObject . They are by far the most adaptable, since any text that can be placed in a variable can then be placed onto the clipboard using the PutInClipboard method. Text can also be brought into a VBA string variable with the GetFromClipboard method. The procedures CopyToClip() and GetFromClip() in the example below first send text to the clipboard, then fetch it again, before displaying the text in a message box. Set a reference to Microsoft Forms 2 in the editor options for this; if you cannot find it just add a user form to your project and it will be added to the selections.
  • Reports of bugs in DataObject methods are reported elsewhere. These apply to Windows versions beyond Win 7, and are reported to involve an unusual persistence between the object and the clipboard. If difficulty is found with these methods then either the dummy userform method or the API methods could be tried.
Sub testCopyAndPaste()
    'demonstrates copy and paste of text to variables
    'loads clipboard with date-time text then
    'fetches it back for display
    'Only good for text and clipboard content lost
    'when application closes.
        
    Dim sStrOut As String, sStrIn As String
    
    'get the current date-time string
    sStrOut = Now
    
    'copy text to clipboard
    CopyToClip sStrOut

    'retrieve from clipboard
    sStrIn = GetFromClip
    
    'display recovered text
    MsgBox sStrIn

End Sub

Function CopyToClip(sIn As String) As Boolean
    'passes the parameter string to the clipboard
    'set reference to Microsoft Forms 2.0 Object Library.
    'If ref not listed, inserting user form will list it.
    'Clipboard cleared when launch application closes.
    
    Dim DataOut As DataObject
    
    Set DataOut = New DataObject
    
    'first pass textbox text to dataobject
    DataOut.SetText sIn
    
    'then pass dataobject text to clipboard
    DataOut.PutInClipboard
    
    'release object variable
    Set DataOut = Nothing
    
    CopyToClip = True
    
End Function

Function GetFromClip() As String
    'passes clipboard text to function name
    'If clipboard not text, an error results
    'set reference to Microsoft Forms 2.0 Object Library.
    'If ref not listed, inserting user form will list it.
    'Clipboard cleared when launch application closes.
    
    Dim DataIn As DataObject
    
    Set DataIn = New DataObject
    
    'clipboard text to dataobject
    DataIn.GetFromClipboard
    
    'dataobject text to function string
    GetFromClip = DataIn.GetText
    
    'release object variable
    Set DataIn = Nothing
    
End Function

Visible User Form Method[edit | edit source]

The code module below provides the VBA code for a form module, (shown here as UserForm1). In it there are command button click routines for textbox Copy and Paste. To use the copy procedure the user simply selects some text then presses the button on the user form. To paste the contents of the clipboard into a textbox, the user must first place the insertion point somewhere within a textbox before pressing the requisite button.

In order to clarify which textbox is active, there is a mouse-up event for each, where a number is loaded into a module-level variable whenever a mouse is used in the box. Although this code is made for three textboxes, it can easily be extended to any number.

The code assumes that there is a user form UserForm1, with TextBox1, TextBox2, TextBox3, CommandButton1 and CommandButton2 in it. In addition, note that there is a module level variable in the code. Since the VBA code is fairly generic it applies to most MS Office applications.

Option Explicit
Dim nActTxtBx As Integer

Private Sub CommandButton1_Click()
'this is the "Paste at Cursor" button
'pastes clipboard active textbox's insertion point
'ie; the textbox last clicked with mouse
            
    Dim oTxt1 As Control, oTxt2 As Control, oTxt3 As Control
    Dim oFrm As UserForm, oTxt As Control, s As Long
    
    Set oFrm = UserForm1
    Set oTxt1 = oFrm.TextBox1
    Set oTxt2 = oFrm.TextBox2
    Set oTxt3 = oFrm.TextBox3
    
    'get the textbox with the focus
    Select Case nActTxtBx
    Case 0
        MsgBox "Please place the insertion point."
        Exit Sub
    Case 1
        Set oTxt = oTxt1
    Case 2
        Set oTxt = oTxt2
    Case 3
        Set oTxt = oTxt3
    Case Else
        Exit Sub
    End Select
    
    s = oTxt.SelStart
    With oTxt
        .Paste
        .SetFocus
        .SelStart = s
    End With

    Set oFrm = Nothing: Set oTxt = Nothing
    Set oTxt1 = Nothing: Set oTxt2 = Nothing
    Set oTxt3 = Nothing
End Sub

Private Sub CommandButton2_Click()
'this is the "Copy Selected Text" button
'copies selected text from textbox to clipboard
'ie; the textbox last clicked with mouse

    Dim oTxt1 As Control, oTxt2 As Control, oTxt3 As Control
    Dim oFrm As UserForm, oTxt As Control
    
    Set oFrm = UserForm1
    Set oTxt1 = oFrm.TextBox1
    Set oTxt2 = oFrm.TextBox2
    Set oTxt3 = oFrm.TextBox3
    
    'get reference to active textbox
    Select Case nActTxtBx
    Case 0
        MsgBox "Please make a selection."
        Exit Sub
    Case 1
        Set oTxt = oTxt1
    Case 2
        Set oTxt = oTxt2
    Case 3
        Set oTxt = oTxt3
    Case Else
        Exit Sub
    End Select
    
    'check that a selection was made
    'MsgBox oTxt.SelLength
    If oTxt.SelLength = 0 Then
        MsgBox "No selection found."
        Exit Sub
    End If
    
    With oTxt
        .Copy
        .SetFocus
        .SelStart = 0
    End With

    Set oFrm = Nothing: Set oTxt = Nothing
    Set oTxt1 = Nothing: Set oTxt2 = Nothing
    Set oTxt3 = Nothing

End Sub

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                                ByVal X As Single, ByVal Y As Single)
    'loads an integer to denote active textbox when mouse makes selection
    nActTxtBx = 1
End Sub

Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                                ByVal X As Single, ByVal Y As Single)
    'loads an integer to denote active textbox when mouse makes selection
    nActTxtBx = 2
End Sub

Private Sub TextBox3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                                ByVal X As Single, ByVal Y As Single)
    'loads an integer to denote active textbox when mouse makes selection
    nActTxtBx = 3
End Sub

Hidden User Form Method[edit | edit source]

This code should be placed in a standard module. The project needs a user form called Temp, with a single TextBox1 set with MultiLine=true. TextBox contents are always text.

Option Explicit

Sub TestClipboardProcs()
'run this
    
    CopyToClipboard "The string" & vbCrLf & _
                    "to copy..."
    MsgBox GetClipboard2

End Sub

Function GetClipboard2() As String
'PASTES clipboard into function name as a text string
'project needs userform named Temp
'with TextBox1 in it set with property Multiline=true
    
    Dim oTxt1 As Control, oFrm As UserForm
    Dim s As Long
    
    'load the temporary form
    Load Temp
    
    Set oFrm = Temp
    Set oTxt1 = oFrm.TextBox1
        
    s = oTxt1.SelStart
    With oTxt1
        .Paste
        .SetFocus
        .SelStart = s
    End With
    
    GetClipboard2 = oTxt1.Value
        
    Set oTxt1 = Nothing
    Set oFrm = Nothing
    Unload Temp

End Function

Function CopyToClipboard(sStr As String) As Boolean
'COPIES parameter variable text string value to clipboard
'project needs userform named Temp
'with TextBox1 in it set with property Multiline=true
    
    Dim oTxt1 As Control, oFrm As UserForm
    
    If sStr = "" Then
        MsgBox "Clipboard cannot hold an empty string."
        Exit Function
    End If
        
    'load the temporary form
    Load Temp
    
    Set oFrm = Temp
    Set oTxt1 = oFrm.TextBox1
    
    oTxt1.Value = sStr
        
    'copy textbox value to clipboard
    With oTxt1
        .SelStart = 0 'set up the selection
        .SelLength = .TextLength
        .Copy
        .SetFocus
        .SelStart = 0
    End With
        
    Set oTxt1 = Nothing
    Set oFrm = Nothing
    Unload Temp

    CopyToClipboard = True

End Function

API Method[edit | edit source]

The code below was tested on an Office 2010 version of Excel, 32 bit system, and worked well. Since that time, with 64 bit 2019 Excel, the code will not work in its current state, but needs further changes to the declarations for 64 bit use.

The following VBA code makes use of API calls, and is recommended by Microsoft in their MS Access page Send-Information-to-the-Clipboard. Such methods should overcome the current bugs in the DataObject methods for Windows 8 and 10. The code should be copied into a standard module in its entirety.

Option Explicit
'Declarations for functions SetClipboard() and GetClipboard()
''from https://docs.microsoft.com/en-us/office/vba/access/concepts/windows-api/send-information-to-the-clipboard
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

Sub TestCopyPasteAPI()
    'API methods for clipboard
    Dim sIn As String, sOut As String
    
    sIn = "Sausages"
    SetClipboard sIn
    sOut = GetClipboard
    MsgBox sOut

End Sub

Public Sub SetClipboard(sUniText As String)
    'sets the clipboard with parameter string
      
    Dim iStrPtr As Long, iLen As Long
    Dim iLock As Long
    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD
    
    OpenClipboard 0&
    EmptyClipboard
    iLen = LenB(sUniText) + 2&
    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
    iLock = GlobalLock(iStrPtr)
    lstrcpy iLock, StrPtr(sUniText)
    GlobalUnlock iStrPtr
    SetClipboardData CF_UNICODETEXT, iStrPtr
    CloseClipboard

End Sub

Public Function GetClipboard() As String
    'gets the clipboard text in function name
    
    Dim iStrPtr As Long, iLen As Long
    Dim iLock As Long, sUniText As String
    Const CF_UNICODETEXT As Long = 13&
    
    OpenClipboard 0&
    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        iStrPtr = GetClipboardData(CF_UNICODETEXT)
        If iStrPtr Then
            iLock = GlobalLock(iStrPtr)
            iLen = GlobalSize(iStrPtr)
            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
            lstrcpy StrPtr(sUniText), iLock
            GlobalUnlock iStrPtr
        End If
        GetClipboard = sUniText
    End If
    CloseClipboard

End Function

See Also[edit | edit source]

  • Send-Information-to-the-Clipboard: A clearly worded page by Microsoft showing how to use API methods for the clipboard. Although described for MS Access, it works in MS Excel just as well.
  • DataObject Bugs Forum: A description of a DataObject bug for Windows versions beyond Win7.


Simple Vigenere Cipher in VBA

Summary[edit | edit source]

  • This VBA code module runs the sixteenth century Vigenere cipher. It is used to conceal the contents of a message, and was probably used in short term military messaging . The method is an early example of an attempt to disguise the natural frequency of the language used in communication. The sender and recipient share a secret word or phrase, the so-called key, used to scramble (encrypt) and unscramble (decrypt) the message. The code does not include spaces, since these tend to assist in code breaking, and although it could have been further restricted to just capital letters, it was decided that adding integers would make it more useful.
  • The code is intended for Microsoft Excel, but is easily adapted to work in other MS Office products that run VBA. For example, to run it in MS Word, the results will still display in the message box, but it will be necessary to comment-out all lines, (put an apostrophe before each), of the '''output to sheet 1'' and ''make columns fit sections''.
  • Figure 1 shows the Vigenere table without integers or other characters. Figure 2, the basis for the coding, shows a similar table that includes integers and capitals, and no other characters.
  • The Vigenere cipher makes use of a repeated keyword or phrase. That is to say, the key string is repeated as often as necessary to cover the message, prior to working. This can be seen in the example of Figure 1, where the very short key "BULGE" was extended to "BULGEBUL" to cover the eight characters of the message. Clearly, the extension of the key in this way avoids any fixed relationship in the encryption, especially when more complex keys are used. A very good description of the "Key Elimination" method for cracking such simplistic keys can be found in Vigenere Cipher.
  • The coded version of the cipher uses a calculation to simulate the tabular method. The twenty-six letters of the alphabet and the ten integers are assigned number values between zero and thirty-five. Then, for encryption, key values are modulo-36 added to message values to make the ciphertext. For decryption, key values are subtracted from the ciphertext, again using modulo-36 arithmetic, and always producing positive values. Numbers are converted back to characters for display.

Notes on the Code[edit | edit source]

Figure 1: The Vigenere cipher uses the intersection of table entries for encryption and a reverse lookup for decryption. Notice in this example that the two instances of the letter E were encrypted differently. The extended table that is the basis of the coding however, can be found in Figure 2.
  • No userform is provided. Instead, type message and key strings, and the boolean value for the working mode, into the top procedure directly. Interested parties might well add a user form of their own.
  • CheckInputs() makes sure that no illegal characters are included, while procedure LongKey() makes a key value equal in length to the message.
  • CharaToMod36() converts each string character, of both message and key, to its set-position number. Another procedure, Mod36ToChara() converts these numbers back again prior to display.
  • AddMod36() performs modulo-36 addition, and subtracts 36 from numbers larger than 35 to keep the result within the set. The procedure SubMod36() performs subtraction, and adds 36 to any negative results, again, to keep the numbers within range.
  • There is some latitude for improvement of the code. For example, the set could be further extended, and the key could be tested to avoid some of the flaws that are characteristic of this cipher. At present, the user must interpret the position for spaces in the decrypted results; this helps to better conceal the use of the frequently used space character. So, extend the set only at the risk of worsened performance. As mentioned before, a user form could be made to replace direct entry.
  • Because repeat patterns can develop, some care is needed in coding. Clearly, a key that consists only of one repeated character would not be very secure, especially if it were the letter A. (Try it!). A good mixture of characters makes for the best key, and if the key completely covers the message without repetition, so much the better. This latter situation helps to avoid patterns that might make for easier cracking. In fact, if instead of a repeated key, a hash of the key were used, many of these pattern weaknesses might be avoided. Those who have an interest in such modifications will find hash procedures elsewhere in this series; (use base64 output). That said, care should be taken to include only alpha characters and integers from any such hash, or errors will result. (B64 strings from hash algorithms typically have three additional symbol characters to avoid, =, +, and /. )

A Larger Vigenere Table[edit | edit source]

Figure 2: Vigenere Cipher Table with Capitals and Integers


If all else fails, and for those who prefer manual working anyway, the table in the above drop-box may be found useful. It lists both capitals and integers. Notice that although both tables have a passing similarity, their content is quite different in places, so they are not fully interchangeable.

A Worked Example[edit | edit source]

The following panel shows how the calculation works for the coded version. It is analogous to the adding and subtraction of character distances within a closed set. Other implementations of the manual method have included the sliding of one set of characters against another for the required distances, sometimes using concentric discs. Figure 2 can be interpreted as a listing of every possible combination of messages and keys.

        THE CHARACTER SET AND ITS VALUES
         A    B    C    D    E    F    G    H    I    J    K    L    M
         0    1    2    3    4    5    6    7    8    9   10   11   12 
         
         N    O    P    Q    R    S    T    U    V    W    X    Y    Z
        13   14   15   16   17   18   19   20   21   22   23   24   25 

         0    1    2    3    4    5    6    7    8    9
        26   27   28   29   30   31   32   33   34   35
        
        
        ENCRYPTION WORKING
         S    E    N    D    H    E    L    P      message               (1)
         B    U    L    G    E                     key             
         B    U    L    G    E    B    U    L      extended key          (2)
        18    4   13    3    7    4   11   15      message values        (3) 
         1   20   11    6    4    1   20   11      key values            (4)
        19   24   24    9   11    5   31   26      (3)+(4)               (5)
         T    Y    Y    J    L    F    5    0      cipher text (Note 1)  (7)

        Note 1:   Subtract 36 from any numbers here that might exceed 35.
        
        Notice that each instance of "E" results in different cipher text.
        
        DECRYPTION WORKING
         T    Y    Y    J    L    F    5    0      cipher text           (8)
         B    U    L    G    E                     key             
         B    U    L    G    E    B    U    L      extended key          (9)
        19   24   24    9   11    5   31   26      cipher text values   (10)         
         1   20   11    6    4    1   20   11      key values           (11)
        18    4   13    3    7    4   11   15      (10) minus (11)      (12)   
         S    E    N    D    H    E    L    P      plain text (Note 2)  (15) 

        Note 2:   Add 36 to any numbers here that might become negative.
        

The VBA Code Module[edit | edit source]

Copy this entire code listing into an Excel standard module, save the file as a xlsm type, then run the top procedure. No user form code has been provided, so the user should enter his message (sTxt) and key (sKey) strings directly into the section identified in the top procedure. Be sure to identify whether encryption or decryption is intended with the setting of the variable bEncrypt.

Corrections:
6 April 2020; corrected a note in SubMod36(); does not affect operation.

Option Explicit

Sub EncryptDecrypt()
    'Run this procedure for a simple Vigenere encryption/decryption
    'Capital letters and integers only; no symbols; no spaces.(ie: mod36 working).
    'Set message, key and mode directly in this procedure before running it.
    'Output to a message box and Excel. Overwrites some cells in Sheet1.
    
    Dim vA() As String, oSht As Worksheet
    Dim nM As Long, c As Long
    Dim sTxt As String, sK As String
    Dim sKey As String, sMode As String, sAccum As String
    Dim bEncrypt As Boolean, bMOK As Boolean, bKOK As Boolean
    
    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    '-------------------------USER ADDS DATA HERE------------------------
    'user should enter texts and encrypt/decrypt choice here
    sTxt = "2019forthecup"  'text to process, plain or cipher
    sKey = "BOGEYMAN"       'Key word or phrase
    bEncrypt = True         'set True for encrypt; False for decrypt
    '---------------------------------------------------------------------
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    
    'convert both strings to upper case
    sTxt = UCase(sTxt)
    sKey = UCase(sKey)
    
    'check the message and key for illegal characters
    'restricted here to capital letters and integers only
    bMOK = CheckInputs(sTxt)
    bKOK = CheckInputs(sKey)
    If bMOK = False Or bKOK = False Then
        If sTxt <> "" And sKey <> "" Then
            MsgBox "Illegal characters found."
        Else
            MsgBox "Empty strings found."
        End If
        Exit Sub
    End If
    
    'make an extended key to match the message length
    nM = Len(sTxt)
    sKey = LongKey(sKey, nM)
        
    'dimension a work array equal in length to the message
    ReDim vA(1 To 10, 1 To nM) '10 rows and nM columns
    
    'read the message, key, and mod-36 values into array
    For c = LBound(vA, 2) To UBound(vA, 2) 'r,c
        'text chara by chara
        vA(1, c) = CStr(Mid$(sTxt, c, 1)) 'message charas
        vA(2, c) = CStr(Mid$(sKey, c, 1)) 'key charas
        'text's converted number values
        vA(3, c) = CStr(CharaToMod36(Mid$(sTxt, c, 1))) 'number values of charas
        vA(4, c) = CStr(CharaToMod36(Mid$(sKey, c, 1))) 'number values of charas
    Next c
       
    'steer code for encrypt or decrypt
    If bEncrypt = True Then 'encrypt
        sMode = " : Encryption result" 'display string
        GoTo ENCRYPT
    Else
        sMode = " : Decryption result" 'display string
        GoTo DECRYPT
    End If

ENCRYPT:
    'sum of converted key and message values mod-36
    'then find string character values of sums
    For c = LBound(vA, 2) To UBound(vA, 2)
        vA(5, c) = CStr(AddMod36(CLng(vA(3, c)), CLng(vA(4, c))))
        vA(6, c) = Mod36ToChara(CLng(vA(5, c)))
    Next c
    
    'accumulate the encrypted charas into a single display string
    'for message box and worksheet
    For c = LBound(vA, 2) To UBound(vA, 2)
        sAccum = sAccum & vA(6, c) 'mixed
    Next c
    GoTo DISPLAY

DECRYPT:
    'subtract key values from encrypted chara values
    'and make negative values positive by adding 36
    'Find string character values of the differences
    For c = LBound(vA, 2) To UBound(vA, 2)
        vA(5, c) = CStr(SubMod36(CLng(vA(3, c)), CLng(vA(4, c))))
        vA(6, c) = Mod36ToChara(CLng(vA(5, c)))
    Next c
    
    'accumulate the encrypted charas into a display string
    'for message box and worksheet
    For c = LBound(vA, 2) To UBound(vA, 2)
        sAccum = sAccum & vA(6, c) 'mixed
    Next c
    GoTo DISPLAY

DISPLAY:
    'message box display
    MsgBox sTxt & " : Text to Process" & vbCrLf & _
           sKey & " : Extended Key" & vbCrLf & _
           sAccum & sMode
    'and output to sheet1 in monospaced font
    With oSht
        .Cells(1, 1).Value = sTxt
        .Cells(1, 2).Value = " : Text to Process"
        .Cells(2, 1).Value = sKey
        .Cells(2, 2).Value = " : Extended Key"
        .Cells(3, 1).Value = sAccum
        .Cells(3, 2).Value = sMode
        .Cells.Font.Name = "Consolas"
        .Columns("A:A").Select
    End With
    
    'make columns fit text length
    Selection.Columns.AutoFit
    oSht.Cells(1, 1).Select

End Sub

Function CheckInputs(sText As String) As Boolean
    'checks message and key for illegal characters
    'here intends use of capitals A-Z, ie ASCII 65-90
    'and integers 0-9, ie ASCII 48-57
    
    Dim nL As Long, n As Long
    Dim sSamp As String, nChr As Long
    
    'check for empty strings
    If sText = "" Then
        MsgBox "Empty parameter string - closing"
        Exit Function
    End If
    
    'test each character
    nL = Len(sText)
    For n = 1 To nL
        'get characters one by one
        sSamp = Mid$(sText, n, 1)
        'convert to ascii value
        nChr = Asc(sSamp)
        'filter
        Select Case nChr
            Case 65 To 90, 48 To 57
                'these are ok
            Case Else
                MsgBox "Illegal character" & vbCrLf & _
                "Only capital letters and integers are allowed; no symbols and no spaces"
                Exit Function
        End Select
    Next n
     
    CheckInputs = True

End Function
        
Function LongKey(sKey As String, nLM As Long) As String
    'makes a repeated key to match length of message
    'starting from the user's key string
    'used in both encryption and decryption
    
    Dim nLK As Long, n As Long, m As Long
    Dim p As Long, sAccum As String
    
    'make long key
    nLK = Len(sKey)
    'if key is longer than message
    If nLK >= nLM Then
        LongKey = Left$(sKey, nLM) 'trim key to fit
        Exit Function
    Else 'message is assumed longer than key
        n = Int(nLM / nLK) 'number of repeats needed
        m = nLM - (n * nLK) 'number of additional characters
        For p = 1 To n
            sAccum = sAccum & sKey
        Next p
        sAccum = sAccum & Left$(sKey, m) 'add any end characters
    End If
    
    LongKey = sAccum

End Function

Function CharaToMod36(sC As String) As Long
    'gets the modulo-36 value of the input character
    'as it exists in the working set
    'For example range A to Z becomes 0 to 25
    'and 0 to 9 become 26 to 35
    
    Dim nASC As Long
    
    'get ascii value of character
    nASC = Asc(sC)
    
    'align charas to working set
    Select Case nASC
    Case 65 To 90
        'subtract 65 to convert to zero based set
        CharaToMod36 = nASC - 65
    Case 48 To 57
        'subtract 22 to convert to zero based set
        CharaToMod36 = nASC - 22
    End Select

End Function

Function Mod36ToChara(nR As Long) As String
    'gets the character for a mod-36 value
    'For example range 0 to 25 becomes A to Z
    'and 26 to 35 become 0 to 9
       
    Select Case nR
    Case 0 To 25 'cap letters, A-Z
        Mod36ToChara = Chr(nR + 65)
    Case 26 To 35 'integers, 0-9
        Mod36ToChara = Chr(nR + 22)
    Case Else
        MsgBox "Illegal character in Mod36ToChara"
        Exit Function
    End Select

End Function

Function AddMod36(nT As Long, nB As Long) As Long
    'adds two positive integers to mod-36, ie set 0-35,
    'that is, no output can exceed 35
            
    Dim nSum As Long
    
    If nT >= 0 And nT < 36 And nB >= 0 And nB < 36 Then
        'inputs are all ok
    Else
        MsgBox "Parameters out of bounds in AddMod36"
    End If
        
    nSum = nT + nB
    
    AddMod36 = nSum Mod 36

End Function

Function SubMod36(nT As Long, nB As Long) As Long
    'subtracts nB from nT mod-36
    'that is, no output can be negative or exceed 35
    'Returns negative results as positive by adding 36
    
    Dim nDif As Long
    
    If nT >= 0 And nT < 36 And nB >= 0 And nB < 36 Then
        'inputs are all ok
    Else
        MsgBox "Parameters out of bounds in SubMod36"
    End If
    
    nDif = nT - nB 'possibly negative
    
    If nDif < 0 Then
        nDif = nDif + 36
    End If
        
    SubMod36 = nDif

End Function

Sub Notes()
    'Notes on the code
    
    'A to Z, correspond to character set positions 0 to 25.
    '0 to 9, correspond to character set positions 26 to 35.
    'The modulus for addition and subtraction is therefore 36.
    'Negative results in calculation are made positive by adding 36.
    'Positive results in calculation greater than 35 are reduced by 36.
    
    'ASCI values made calculation simple here but a more general version could
    'preload any character set for lookup with alternative coding.
        
    'See Wikibooks text for a table image and further details.

End Sub

See Also[edit | edit source]


Error Handling

Summary[edit | edit source]

The code module below shows one layout method for error handling. It uses a bit more space than the usual thing but has good clarity. It also includes error logging and a block for testing the code by raising errors. Only a few errors have been listed.

Notice that no formatting is done in the log writing procedure itself, and that a choice of block logs with line separation or serial logs with comma-separation are both included.

VBA Code[edit | edit source]

Option Explicit

Sub ErrorCodeShell()
    'time saving errors code shell
   

On Error GoTo ERR_HANDLER
    
    '===================================
    'Main body of procedure goes here...
    '===================================
    
    '===================================
    '   Raise Errors Here For Testing
    '===================================
    'Err.Raise 6  'overflow
    Err.Raise 11 'div zero
    'Err.Raise 53 'file not found
    'Err.Raise 70 'permission denied
    '===================================
    
    Exit Sub
ERR_HANDLER:
    If Err.Number <> 0 Then
        'LOG ERROR DETAILS
        
        'make error messages
        Dim sE1 As String, sE2 As String
        Dim oErr1 As ErrObject, oErr2 As ErrObject
        
        'make error messages
        Set oErr1 = Err: Set oErr2 = Err
        sE1 = Message1(oErr1) 'block style message
        sE2 = Message2(oErr2) 'serial style
        Set oErr1 = Nothing: Set oErr2 = Nothing
                
        'enable logging as block or serial format
        LogError3 sE1   'write to log block style
        'LogError3 sE2   'write to log serial style
                
        'write to immediate window
        Debug.Print sE1 'block style
        'Debug.Print sE2 'serial style
        
        'selective error handling
        Select Case Err.Number
        Case 53
            GoTo FileNotFound
        Case 70
            GoTo PermissionDenied
        Case Else:
            GoTo OtherErrors
        End Select
FileNotFound:
        'Handle the error
        Err.Clear
        Exit Sub
PermissionDenied:
        'Handle the error
        Err.Clear
        Exit Sub
OtherErrors:
        MsgBox sE1
        Err.Clear
        Exit Sub
    End If

End Sub

Function LogError3(sIn As String) As Boolean
    'logs parameter string to a text file
    'assumes same path as calling Excel workbook
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim sPath As String, Number As Integer
    
    Number = FreeFile 'Get a file number
    sPath = ThisWorkbook.Path & "\error_log3.txt" 'modify path\name here
    
    Open sPath For Append As #Number
    Print #Number, sIn
    Close #Number

    LogError3 = True
            
End Function

Function Message1(oE As ErrObject) As String
    'makes block style message for error
    
    Dim sEN As String, sSrc As String
    Dim sDesc As String, sDT As String
    
    'make date-time string
    sDT = Format(Now, "d mmm yyyy") & ", " & _
                   Format(Now, "dddd hh:mm:ss AMPM")
    
    'get error parts
    sEN = CStr(oE.Number)   'number of error
    sSrc = oE.Source        'source of error
    sDesc = oE.Description  'description of error
    
    'make block message with line separations
    Message1 = sDT & vbNewLine & _
        "Error number: " & sEN & vbNewLine & _
        "Source: " & sSrc & vbNewLine & _
        "Description: " & sDesc & vbNewLine

End Function

Function Message2(oE As ErrObject) As String
    'makes serial style message for error
    
    Dim sEN As String, sSrc As String
    Dim sDesc As String, sDT As String
    
    'make date-time string
    sDT = Format(Now, "dddd yyyy mmm d hh:mm:ss")
    
    'get error parts
    sEN = CStr(oE.Number)   'number of error
    sSrc = oE.Source        'source of error
    sDesc = oE.Description  'description of error
    
    'make serial message with comma separations
    Message2 = sDT & ",Error " & sEN & "," & sSrc & "," & sDesc

End Function

See Also[edit | edit source]

External Links[edit | edit source]


File and Folder Dialogs

Summary[edit | edit source]

At times we need to access files and folders to provide input for procedures, and the code below will do this. They are not much different to the dialogs that Windows uses, and each of them works by returning a full path string to the chosen item. When a folder is selected, the returned string does not include the end backslash; the user needs to add that himself.

The two dialogs ''SelectFolder()'' and ''SelectFile()'' will work with both 32 bit and 64 bit version of MS Office, but the API procedure ''BrowseFolder()'' is not intended for 64 bit working; it works only in 32 bit systems. For completeness, another version of the API for 64 bit systems has been added at the foot of the page. Although these two look a bit similar, it is important to choose the right one for your version of MS Office. All three can be run from the test procedure.

Just copy the entire code listing into a standard module for use, and comment out the API version that is unwanted, assuming that an API is used at all.

VBA Code Module[edit | edit source]

The default file-type listing that opens in SelectFile() is decided by which of the Filters.Add code lines appears first in the sequence. For example, to have the All Files as your prefered listing, just move that line so that it immediately follows the Filters Clear line. Of course, the listing can also be changed by selecting the drop menu while the dialog is open.

Option Explicit
Option Private Module
Option Compare Text
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'This API procedure is for 32 bit systems only; see below for a 64 bit API
    ' API version code credit to Chip Pearson at http://www.cpearson.com/excel/browsefolder.aspx
    ' This contains the BrowseFolder function, which displays the standard Windows Browse For Folder
    ' dialog. It returns the complete path of the selected folder or vbNullString if the user cancelled.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Private Const BIF_RETURNONLYFSDIRS As Long = &H1
    Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
    Private Const BIF_RETURNFSANCESTORS As Long = &H8
    Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
    Private Const BIF_BROWSEFORPRINTER As Long = &H2000
    Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
    
    
    Private Type BROWSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszINSTRUCTIONS As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type
    
    
    Private Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, _
        ByVal pszBuffer As String) As Long
    
    Private Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As _
        BROWSEINFO) As Long
    
    
    Private Const MAX_PATH = 260 ' Windows mandated

Sub TestBrowseFilesAndFolders()
    
    Dim sRet As String
    
    'run to test the file selection dialog
    sRet = SelectFile("Select a file...")
    
    'run to test the folder selection dialog
    'sRet = SelectFolder("Select a folder...")
    
    'run to test the API folder selection dialog
    'sRet = BrowseFolder("Select a folder...")
    
    MsgBox sRet

End Sub

Function BrowseFolder(Optional ByVal DialogTitle As String = "") As String
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' BrowseFolder
    ' This displays the standard Windows Browse Folder dialog. It returns
    ' the complete path name of the selected folder or vbNullString if the
    ' user cancelled.   Returns without and end backslash.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    If DialogTitle = vbNullString Then
        DialogTitle = "Select A Folder..."
    End If
    
    Dim uBrowseInfo As BROWSEINFO
    Dim szBuffer As String
    Dim lID As Long
    Dim lRet As Long
    
    
    With uBrowseInfo
        .hOwner = 0
        .pidlRoot = 0
        .pszDisplayName = String$(MAX_PATH, vbNullChar)
        .lpszINSTRUCTIONS = DialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS ' + BIF_USENEWUI
        .lpfn = 0
    End With
    szBuffer = String$(MAX_PATH, vbNullChar)
    lID = SHBrowseForFolderA(uBrowseInfo)
    
    If lID Then
        ''' Retrieve the path string.
        lRet = SHGetPathFromIDListA(lID, szBuffer)
        If lRet Then
            BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1)
        End If
    End If

End Function

Function SelectFolder(Optional sTitle As String = "") As String
    'opens a file-select dialog and on selection
    'returns its full path string in the function name
    'If Cancel or OK without selection, returns empty string
    'Returns path string without an end backslash.
    
    Dim sOut As String
        
    With Application.FileDialog(msoFileDialogFolderPicker)
        'see also msoFileDialogFolderPicker, msoFileDialogOpen, and msoFileDialogSaveAs
        'uses Excel's default opening path but any will do
        'needs the backslash in this case
        .InitialFileName = Application.DefaultFilePath & " \ "
        .Title = sTitle
        .Show
        If .SelectedItems.Count = 0 Then
            'MsgBox "Canceled without selection"
        Else
            sOut = .SelectedItems(1)
            'MsgBox sOut
        End If
    End With

    SelectFolder = sOut

End Function

Function SelectFile(Optional sTitle As String = "") As String
    'opens a file-select dialog and on selection
    'returns its full path string in the function name
    'If Cancel or OK without selection, returns empty string
    
    Dim fd As FileDialog, sPathOnOpen As String, sOut As String
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    'do not include backslash here
    sPathOnOpen = Application.DefaultFilePath
    
    'set the file-types list on the dialog and other properties
    With fd
        .Filters.Clear
        .Filters.Add "Excel workbooks", "*.xlsx;*.xlsm;*.xls;*.xltx;*.xltm;*.xlt;*.xml;*.ods"
        .Filters.Add "Word documents", "*.docx;*.docm;*.dotx;*.dotm;*.doc;*.dot;*.odt"
        .Filters.Add "All Files", "*.*"
        
        .AllowMultiSelect = False
        .InitialFileName = sPathOnOpen
        .Title = sTitle
        .InitialView = msoFileDialogViewList 'msoFileDialogViewSmallIcons
        .Show
        
        If .SelectedItems.Count = 0 Then
            'MsgBox "Canceled without selection"
            Exit Function
        Else
            sOut = .SelectedItems(1)
            'MsgBox sOut
        End If
    End With
    
    SelectFile = sOut

End Function
Option Explicit
Option Compare Text

    Private Type BROWSEINFO
        hOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type
    
    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
            (ByVal pidl As LongPtr, ByVal pszPath As String) As Long
            
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
        (lpBrowseInfo As BROWSEINFO) As LongPtr

Private Const BIF_RETURNONLYFSDIRS = &H1

Sub a_testBrowseFolder2()
    'Tests the 64 bit version of the API BrowsFolder2
    
    Dim sFPath As String

    sFPath = BrowseFolder2("Please select a folder.")

    MsgBox sFPath

End Sub

Public Function BrowseFolder2(Optional sTitle As String = "") As String
    'This version of the BrowsFolder API is for 64 bit systems. For 32 bit systems use one at top of page
    'This function returns a folder path string as selected in the browse dialog, without a trailing backslash.
    'Credit is given to Peter De Baets, from which this procedure was trimmed for 64 bit only.
  
    Dim x As Long, Dlg As BROWSEINFO
    Dim DlgList As LongPtr
    Dim sPath As String, Pos As Integer
    Dim sRet As String
  
    sRet = ""
  
    With Dlg
        '.hOwner = hWndAccessApp 'errors
        .lpszTitle = sTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    
    DlgList = SHBrowseForFolder(Dlg)
    sPath = Space$(512)
    x = SHGetPathFromIDList(ByVal DlgList, ByVal sPath)
    
    If x Then
        Pos = InStr(sPath, Chr(0))
        sRet = Left$(sPath, Pos - 1)
    Else
        sRet = ""
    End If
        
    BrowseFolder2 = sRet

End Function

See Also[edit | edit source]

External Links[edit | edit source]

  • BrowseFolder  : Chip Pearson's page on the API folder browser.
  • FileDialog Properties and Methods: The Microsoft documentation for the FileDialog selection methods. It includes a code panel showing the use of file multi-selection.


Recursive File Listing of Folders

Summary[edit | edit source]

  • Recursive listings are tricky, and it is found to be difficult without module or public declarations of some sort. This version although a bit clumsy will perform as expected for files that can be accessed.
  • A public variable is used as a counter to keep track, between iterations, of the numbers of files found, since Microsoft advises us that static variables are not usually used with recursion. The VBA code is not specific for any particular Office application, so would work in say MS Excel or MS Word etc.
  • The user might need to introduce more filtering; for example, to exclude certain file types, or to avoid those of zero size. A comment in the code listing shows where such a code function could be added to the existing condition.
  • Because the array is public, it can be accessed from any other module for its further processing or output. Copy the code entirely into a code module, and modify the folder and recursion condition to your own values.
  • My Documents versus Documents. There are four virtual folders in Libraries, My Documents, My Music, My Pictures, and My Videos. When the Windows Explorer's Folder Options forbid the display of hidden files, folders, and drives, the correct locations are returned by various folder selection dialogs, namely Documents, Music, Pictures, and Videos. When hidden folders are permitted, then dialogs and listings will attempt to make use of these virtual paths. Access violations will result. To avoid undue problems, check that your folder options are set not to show hidden files or folders. This procedure avoids these folders altogether, but access violations can be avoided, provided that hidden files are allowed to stay hidden.

VBA Code[edit | edit source]

Option Explicit
Option Base 1

Public vA() As String
Public N As Long


Sub MakeList()
    'loads an array with details of the files in the selected folder.
    
    Dim sFolder As String, bRecurse As Boolean
    
    'NOTE
    'The Windows virtual folders My Music, My Videos, and My Pictures
    'generate (handled) error numbers 70,90,91 respectively, so are avoided.
    'Alternatively, set Folder Options to not show hidden files and folders
    'to avoid the problem.
    
    'set folder and whether or not recursive search applies
    sFolder = "C:\Users\My Folder\Documents\Computer Data\"
    bRecurse = True

    'erase any existing contents of the array
    Erase vA()  'public string array
        
    'this variable will accumulate the result of all recursions
    N = 0 'initialize an off-site counting variable
            
    'status bar message for long runs
    Application.StatusBar = "Loading array...please wait."
    
    'run the folder proc
    LoadArray sFolder, bRecurse
        
    If N = 0 Then
       Application.StatusBar = "No Files were found!"
       MsgBox "NO FILES FOUND"
       Application.StatusBar = ""
       Exit Sub
    Else
       'status bar message for long runs
       Application.StatusBar = "Done!"
       MsgBox "Done!" & vbCrLf & N & " Files listed."
       Application.StatusBar = ""
       Exit Sub
    End If

End Sub

Sub LoadArray(sFolder As String, bRecurse As Boolean)
    'loads dynamic public array vA() with recursive or flat file listing
       
    'The Windows folders My Music, My Videos, and My Pictures
    'generate error numbers 70,90,91 respectively, and are best avoided.
    
    Dim FSO As Object, SourceFolder As Object, sSuff As String, vS As Variant
    Dim SubFolder As Object, FileItem As Object, sPath As String
    Dim r As Long, Count As Long, m As Long, sTemp As String
    
    'm counts items in each folder run
    'N (public) accumulates m for recursive runs
    m = m + N
        
    On Error GoTo Errorhandler
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(sFolder)
    
    For Each FileItem In SourceFolder.Files
        DoEvents
        sTemp = CStr(FileItem.Name)
        sPath = CStr(FileItem.path)
        
        'get suffix from fileitem
        vS = Split(CStr(FileItem.Name), "."): sSuff = vS(UBound(vS))
        
        If Not FileItem Is Nothing Then 'add other file filter conditions to this existing one here
            m = m + 1 'increment this sourcefolder's file count
            'reset the array bounds
            ReDim Preserve vA(1 To 6, 0 To m)
            r = UBound(vA, 2)
                'store details for one file on the array row
                vA(1, r) = CStr(FileItem.Name)
                vA(2, r) = CStr(FileItem.path)
                vA(3, r) = CLng(FileItem.Size)
                vA(4, r) = CDate(FileItem.DateCreated)
                vA(5, r) = CDate(FileItem.DateLastModified)
                vA(6, r) = CStr(sSuff)
        End If
    Next FileItem
    
    'increment public counter with this sourcefolder count
    N = m  'N is public
    
    'this bit is responsible for the recursion
    If bRecurse Then
        For Each SubFolder In SourceFolder.SubFolders
            LoadArray SubFolder.path, True
        Next SubFolder
    End If
       
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    Exit Sub

Errorhandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
        Case 70 'access denied
            'MsgBox "error 70"
            Err.Clear
            Resume Next
        Case 91 'object not set
            'MsgBox "error 91"
            Err.Clear
            Resume Next
        Case Else
            'MsgBox "When m = " & m & " in LoadArray" & vbCrLf & _
            "Error Number :  " & Err.Number & vbCrLf & _
            "Error Description :  " & Err.Description
            Err.Clear
            Exit Sub 'goes to next subfolder - recursive
        End Select
    End If

End Sub


File and Folder Utilities

Summary[edit | edit source]

  • This first set of utilities concentrates on the basic FileSystemObject set; that is, the set used to find whether or not a file or folder exists, what their sizes are, and whether or not they have a particular attribute. A basic path parsing procedure is also provided. All of these procedures need a reference set in the VBA editor to Microsoft Scripting Runtime
  • No universally useful code was found for testing for open files. Although many procedures exist, they all fail in some way, usually failing to identify open text or image files, or Office files that are marked as read-only. The basis of the problem is that many such files in Windows do not lock when opened by a user, so procedures that attempt to detect the open state by trying for sole access, cannot do so. Any reader with a universal solution is, as always, invited to comment.

VBA Notes[edit | edit source]

At times it is useful to know whether or not a file or folder has a particular attribute, for example, to avoid hidden or system files in listings. The procedure HasAttribute does this, taking a path to the file as parameter and a short-code to identify the attribute of interest. However, the attribute bundle is delivered with all of the attribute number values added together, so this type of test, like other enumerations that involve constants (eg; the message box types), makes use of the AND function to split the bundle.

For example: (See procedure HasAttribute below.) Assume that the attribute bundle from GetAttr equals 37
and that we are testing for the "system" attribute only ("S") with vbSystem = 4. Now, for numbers,
the AND operator performs a bitwise AND on each column, so gives:

01001012 = 3710 = vbArchive + vbSystem + vbReadOnly
00001002 = 410 = vbSystem
_______
00001002 = 410, interpreted by boolean variables as True since it is non-zero

That is to say, the "system" attribute is present in the attribute bundle.
If the "system" attribute were not set, then the result would have been all zeros

It is important to note that the returned value tests only one attribute at a time; that is to say, although a file returns true for for read-only ("R"), it might also have other attributes that are not tested. If users would rather have all of the file or folder attributes returned in one string, some work might be done to concatenate the result codes.

An example of file path parsing is given in the ParsePath procedure. The example uses the Split function to place all of the backslash separated terms into an array, then recombines them to make the path. A similar method, split on the dot is used to make the file name and suffix.

VBA Code Module[edit | edit source]

Option Explicit

Function FileFound(sPath As String) As Boolean
    'returns true if parameter path file found
    
    Dim fs As FileSystemObject
          
    'set ref to fso
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'test for file
    FileFound = fs.FileExists(sPath)
        
    Set fs = Nothing
    
End Function

Function FolderFound(sPath As String) As Boolean
    'returns true if parameter path folder found
    
    Dim fs As FileSystemObject
          
    'set ref to fso
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'test for folder
    FolderFound = fs.FolderExists(sPath)
        
    Set fs = Nothing
    
End Function

Function GetFileSize(sPath As String, nSize As Long) As Boolean
    'returns file size in bytes for parameter path file
    
    Dim fs As FileSystemObject, f As File
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FileExists(sPath) Then
        Set f = fs.GetFile(sPath)
        nSize = f.Size
        GetFileSize = True
    End If

    Set fs = Nothing: Set f = Nothing

End Function

Function GetFolderSize(sPath As String, nSize As Long) As Boolean
    'returns total content size in bytes for parameter path folder
    
    Dim fs As FileSystemObject, f As Folder
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FolderExists(sPath) Then
        Set f = fs.GetFolder(sPath)
        nSize = f.Size
        GetFolderSize = True
    End If
    
    Set fs = Nothing: Set f = Nothing

End Function

Function HasAttribute(sPath As String, sA As String) As Boolean
    'returns true if parameter path file or folder INCLUDES test parameter
    'eg: if sA= "H" then returns true if file attributes INCLUDE "hidden"
    'Untested attributes might also exist
    
    'sA values
    '"R"; read only, "H"; hidden, "S"; system, "A"; archive
    '"D"; directory, "X"; alias, "N"; normal
        
    Dim bF As Boolean, nA As Integer
    Dim bFile As Boolean, bFldr As Boolean
    Dim fs As FileSystemObject, f As File, fd As Folder
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'check path parameter
    bFile = fs.FileExists(sPath)
    bFldr = fs.FolderExists(sPath)
    
    If bFile Or bFldr Then
        'get its attribute bundle
        nA = GetAttr(sPath)
    Else
        'neither found so exit
        MsgBox "Bad path parameter"
        GoTo Wayout
    End If
        
    'early exit for no attributes
    If nA = 0 And sA = "N" Then                   '0
        HasAttribute = True
        Exit Function
    End If
    
    'test for attribute in sA
    'logical AND on number variable bit columns
    If (nA And vbReadOnly) And sA = "R" Then      '1
        bF = True
    ElseIf (nA And vbHidden) And sA = "H" Then    '2
        bF = True
    ElseIf (nA And vbSystem) And sA = "S" Then    '4
        bF = True
    ElseIf (nA And vbDirectory) And sA = "D" Then '16
        bF = True
    ElseIf (nA And vbArchive) And sA = "A" Then   '32
        bF = True
    ElseIf (nA And vbAlias) And sA = "X" Then     '64
        bF = True
    End If
    
    HasAttribute = bF

Wayout:
    Set fs = Nothing: Set f = Nothing: Set fd = Nothing

End Function

Function ParsePath(sPath As String, Optional sP As String, _
                   Optional sF As String, Optional sS As String) As Boolean
    'sPath has full file path
    'returns path of file with end backslash (sP),
    'file name less suffix (sF), and suffix less dot(sS)
    
    Dim vP As Variant, vS As Variant, n As Long
    Dim bF As Boolean, fs As FileSystemObject
        
    'set ref to fso
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'test that file exists
    bF = fs.FileExists(sPath)

    If Not bF Then
        'MsgBox "File not found"
        GoTo Wayout
    End If
        
    'make array from path elements split on backslash
    vP = Split(sPath, "\")
    
    'make array from file name elements split on dot
    vS = Split(vP(UBound(vP)), ".")

    'rebuild path with backslashes
    For n = LBound(vP) To UBound(vP) - 1
        sP = sP & vP(n) & "\"
    Next n
     
    sF = vS(LBound(vS))
    sS = vS(UBound(vS))

    ParsePath = True

Wayout:
    Set fs = Nothing

End Function

See Also[edit | edit source]

External Links[edit | edit source]


Font Utilities

Summary[edit | edit source]

  • This page lists VBA procedures that are mainly to do with fonts. That is to say, how VBA handles fonts.
  • The function GetTextPoints() finds the width of text in points. A label on a userform extends when loaded with the string. The width is then read from the control. The userform and its contents are loaded but never shown. Despite its seeming lack of elegance, this method is perhaps the simplest way of getting the fitting width for text, correct for any variation in the font. The function is useful in the precise sizing of controls for complex layouts, such as tables within text boxes.
  • The procedure ListAllExcelFonts() lists Excel's fonts on a worksheet. It makes use of GetTextPoints(). While listing whether or not the font is monospaced, it also makes a sample of test text in each font. It also lists the width in points for the sample text in each font. Normalizing these width figures might be more useful but it is unclear as to which font is best to represent the standard. As ever, informed comments would be useful.
  • The procedure FontExists() tests whether or not a font exists. It returns true in the function name if the parameter font name exists, otherwise it returns false. Run testit() to try the function.

Font Tests[edit | edit source]

The function GetTextPoints() can be used to determine whether or not a font is monospaced. Although at first sight it would appear suitable for determining the presence of kerning, the userform control used to measure the width of text does not kern the text applied to it in any case. As such, kerning will always be found to be absent. The tests, whether used visually or in an automated mode, compare the lengths of selected strings. If the strings of the first pair below are the same length, then the font is monospaced. Elsewhere, if kerning had been applied, then the strings of the second pair would be different in length.

Monospace test strings:
IIIIIIIIII
HHHHHHHHHH

Kerning test strings: for completeness only.
AAAAATTTTT
ATATATATAT

Code Module Notes[edit | edit source]

Code Module[edit | edit source]

Revisions[edit | edit source]

Sub TestGetTextPoints()
    'Run this to obtain the points width of text
    
    ' Get the net width in points for the string
    MsgBox GetTextPoints("The quick brown fox jumps over the lazy dog", "Consolas", 12, 0, 0) & _
                         " points width"
End Sub

Function GetTextPoints(sIn As String, sFontName As String, _
    nFontSize As Single, bFontBold As Boolean, _
    bFontItalic As Boolean) As Long
    'GetTextPoints returns points width of text.
    'When setting a control width, add two additional
    'space widths to these values to avoid end clipping.
    'Needs a user form called CountPoints. Form
    'is loaded and unloaded but never shown.
        
    'Monospace test: could be used here to identify monospaced fonts
    'If pair is same width then monospaced
    'IIIIIIIIII
    'HHHHHHHHHH
    
    'Kerning test pair used by printers: Wont work here since there is no kerning in userform controls.   
    'If pair are different width then there is kerning.
    'AAAAATTTTT
    'ATATATATAT

    Dim oLbl As Control
    
    Load CountPoints
    Set oLbl = CountPoints.Controls.Add("Forms.Label.1", "oLbl")

    'format the label with same fonts as sIn
    With oLbl
        .Width = 0
        .WordWrap = False
        .Visible = False
        .AutoSize = True
        .Caption = ""
        .font.SIZE = nFontSize
        .font.Name = sFontName
        .font.Bold = bFontBold
        .font.Italic = bFontItalic
    End With

    'get points for sIn
    oLbl.Caption = sIn
    GetTextPoints = oLbl.Width

    Unload CountPoints

End Function

Sub ListAllExcelFonts()
    'Lists Excel fonts as monospaced or proportional
    'with a sample of text and its width in points
    'calls GetTextPoints to measure test strings
    'needs use of Sheet1 - clears all existing
    
    Dim FontList, sht As Worksheet, i As Long
    Dim sM1 As String, sM2 As String, sFN As String
    Dim sTest As String, nSize As Single
    Dim bBold As Boolean, bItalic As Boolean
    
    'monospaced test strings
    sM1 = "IIIIIIIIII"
    sM2 = "MMMMMMMMMM"
    
    'set a suitable test string here
    sTest = "The quick brown fox jumps over the lazy dog 1234567890"
    
    'set test parameters
    nSize = 10 'ten point for all tests
    bBold = False
    bItalic = False
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    With sht
        .Activate
        .Range("A1:Z65536").ClearContents
        .Range("A1:Z65536").ClearFormats
    End With
    
    'get reference to the font list
    Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
    
    On Error Resume Next
    'work loop
    For i = 1 To FontList.ListCount
        
        sFN = FontList.List(i) 'font name
        
        'print general data to sheet
        With sht
            .Cells(i, 1) = sFN                                              'name
            .Cells(i, 3) = GetTextPoints(sTest, sFN, nSize, bBold, bItalic) 'test string pts width
        End With
        
        'set fonts for sample cell
        With sht.Cells(i, 4).font
            .Name = sFN
            .SIZE = nSize
            .Italic = bItalic
            .Bold = bBold
        End With
        
        'sample string to sheet
        sht.Cells(i, 4) = sTest
        
        'monospaced  test - true if both test strings equal in length
        If GetTextPoints(sM1, sFN, nSize, bBold, bItalic) = GetTextPoints(sM2, sFN, nSize, bBold, bItalic) Then
            'the test font is monospaced
            sht.Cells(i, 2) = "Monospaced"  'mono or prop
        Else
            sht.Cells(i, 2) = "Proportional"
        End If
    Next i
        
    With sht
        .Columns.AutoFit
        .Cells(1, 1).Select
    End With

End Sub

Private Sub testit()
    ' Find whether or not a font exists
    Dim sFontName As String
    
    sFontName = "Consolas"
    
    If FontExists(sFontName) Then
        MsgBox sFontName & " exists"
    Else
        MsgBox sFontName & " does not exist"
    End If

End Sub

Public Function FontExists(FontName As String) As Boolean
    ' Returns true in function name
    ' if parameter font name exists
    
    Dim oFont As New StdFont
    
    oFont.Name = FontName
    If StrComp(FontName, oFont.Name, vbTextCompare) = 0 Then
        FontExists = True
    End If
    
End Function

See Also[edit | edit source]

External Links[edit | edit source]


The Elusive Button

Summary[edit | edit source]

These VBA code modules are intended for Microsoft Excel. They show how to make a button that continually escapes attempts to click it. The code needs only a user form called UserForm1, and two command buttons, CommandButton1 and CommandButton2; The code will size the controls and the form itself.

Code Notes[edit | edit source]

  • The MouseMove event applies to specific controls; in this case a CommandButton. It fires whenever the mouse moves anywhere within the area of the control, and is used here to move the control before the user can select it.
  • The code proposes random direction and shift amounts, then checks to make sure that the resulting shift will stay on the form, before moving the control. When a proposed shift is rejected, the fact that the mouse is still moving ensures that another event will still fire before a selection can be made. Selection HAS been known to happen, perhaps when there is an unlikely number of rejected shift values; a click procedure has been included to note the fact, just in case.
  • The VBA help page for this event has an impressive set of options, as yet unexplored here.

The ThisWorkbook Module[edit | edit source]

Copy this code into the ThisWorkbook module of the project. Save the file as xlsm type. It will run whenever the file is opened.

Private Sub Workbook_Open()
   'loads the user form at file open
   
   Load UserForm1
   UserForm1.Show

End Sub

The Userform1 Module[edit | edit source]

Copy this code into the UserForm1 module. It can be accessed by double-clicking the userform in design mode. Save the file, making sure it is xlsm type. The code is run by opening the file or by clicking the above Open event procedure in the ThisWorkbook module.

Code Modifications[edit | edit source]

Added colors and overlaps, 2 Feb 2019
Added notes to code, 2 Feb 2019

Option Explicit

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, _
            ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'Runs whenever the mouse moves anywhere on the CommandButton control.
    'Shifts the control when that happens, provided that the proposed
    'random shift will still allow the control to stay on the form.
        
    Dim Lrand1 As Long, Lrand2 As Long, Lstartval As Single, LMyrand As Long
    Dim Trand1 As Long, Trand2 As Long, Tstartval As Single, TMyrand As Long
    
    'propose random horizontal jump direction and distance
    Lrand1 = 1 'direction
    Lstartval = Rnd 'fractional
    If Lstartval < 0.5 Then Lrand1 = -1
        Lrand2 = Int((70 - 45 + 1) * Rnd + 45) 'distance
        LMyrand = Lrand1 * Lrand2 'direction and distance
     
    'propose random vertical jump direction and distance
    Trand1 = 1 'direction
    Tstartval = Rnd 'fractional
    If Tstartval < 0.5 Then Trand1 = -1
        Trand2 = Int((70 - 45 + 1) * Rnd + 45) 'distance
        TMyrand = Trand1 * Trand2 'direction and distance
    
    With CommandButton1
        Select Case Lrand1
        Case 1 'positive shift to right
            'if shift still on userform...
            If .Left + LMyrand + .Width < UserForm1.Width + 10 Then
               .Left = .Left + LMyrand 'shift
            Else
               'do nothing - will fire again
            End If
        Case -1 'negative shift to left
            'if shift still on userform...
            If .Left + LMyrand > -10 Then
               .Left = .Left + LMyrand 'shift
            Else
               'do nothing - will fire again
            End If
        End Select
    
        Select Case Trand1
        Case 1 'positive shift down
            'if shift still on userform...
            If .Top + TMyrand + .Height < UserForm1.Height + 10 Then
               .Top = .Top + TMyrand 'shift
            Else
               'do nothing - will fire again
            End If
        Case -1 'negative shift up
            'if shift still on userform...
            If .Top + TMyrand > -10 Then
               .Top = .Top + TMyrand 'shift
            Else
               'do nothing - will fire again
            End If
        End Select
    End With

End Sub

Private Sub CommandButton1_Click()
    'runs if user can select button
    'Rare, but it can happen
    
    MsgBox "It had to happen sometime!"
    
End Sub

Private Sub CommandButton2_Click()
    'runs from alternative choice
    'to stop process and unload form
    
    UserForm1.Hide
    Unload UserForm1

End Sub

Private Sub UserForm_Initialize()
    'runs after loading but before show
    'sets initial values of form and controls
    
    With UserForm1
        .Height = 250
        .Width = 250
        .BackColor = RGB(9, 13, 147)
        .Caption = "Ambitious?..."
    End With
    With CommandButton1
        .Height = 55
        .Width = 55
        .Top = 45
        .Left = 55
        .BackColor = RGB(255, 172, 37)
        .Caption = "Press if" & vbCrLf & "you want" & vbCrLf & "a raise"
    End With
    With CommandButton2
        .Height = 55
        .Width = 55
        .Top = 45
        .Left = 140
        .BackColor = RGB(222, 104, 65)
        .Caption = "No thanks?"
    End With
End Sub

See Also[edit | edit source]


String Hashing in VBA

Summary[edit | edit source]

  • The VBA code below generates the digests for the MD5, SHA1, SHA2-256, SHA2-384, and SHA2-512 hashes; in this case for strings.
  • A hash is an output string that resembles a pseudo random sequence, and is essentially unique for any string that is used as its starting value. Hashes cannot be easily cracked to find the string that was used in their making and they are very sensitive to input change. That is to say, just a change in one character at the start will produce a completely different output. Hashes can be used as the basis of pseudo random character tables, and although not purely random, such methods can produce output quality that is at least as good as the in-built Rnd() function of VBA.
  • The use of a hash allows programmers to avoid the embedding of password strings in their code.
    • The memory space occupied by an application can be read with special utilities, so passwords might be found in code, then used in a normal user login. Instead, the hash of the password is listed in code, and the password is hashed for comparison only during a logon. This avoids access to the application via the conventional user route, since any hash that is found could not be reverse engineered to obtain the value needed at the user interface. This method assumes that the code cannot be run by the intruder at any location other than the logon device, and that they are unable to change the memory contents.
    • If a hacker can change the memory contents, then a common exploit is to change the hash in memory for one of their own; one that corresponds to a password that they can use at the user logon interface. The counter action against this attack is for all of the logon files to be encrypted with the user's officially issued password. Then, even if the hash is changed, the files needed for the logon attempt cannot be decrypted for use.
  • Hashes can also be made from entire files, and the code for doing so differs only slightly from the string hashing versions given below. The main difference in file hashing is that the file is first turned into a string before using conventional techniques. Code is given elsewhere in this series for file hashing. String hashes will produce an output even when the empty string is used as a starting point, unlike for file hashing where an empty text file can raise errors.
  • This VBA code is not specific for any one application, so it will work in any of say, MS Word, MS Excel, or MS Access. These code versions include options for base-64 output or hex.

Code Listings[edit | edit source]

Notes on the Code[edit | edit source]

IMPORTANT. It was found that the hash routines errored in a Windows 10, 64 bit Office setup. However, subsequent checking revealed the solution. The Windows platform must have intalled the Net Framework 3.5 (includes .Net 2 and .Net 3), this older version, and not only the Net Framework 4.8 Advanced Services that was enabled in Turn Windows Features on and off. When it was selected there, the routines worked perfectly.

The VBA code below generates the digests for the MD5, SHA1, SHA2-256, SHA2-384, and SHA2-512 hashes, for strings, in either of the hex or base-64 output formats. These codings each make use of MS Office's built-in functions, and provide consistent results. It has been noted that original implementations elsewhere for the same digests can differ widely in their outputs. Only one example has been given with a seed or salt parameter (StrToSHA512Salt), and it should be noted that the HMACSHA512 class output differs from the SHA*Managed class hashes given in the remainder. The Managed classes give the best widely reported results. Note the VBA references required for correct operation. A reminder of these is given in some procedure headings.

In each case, coders can find the unmodified hash values in the bytes() array and at that point they are in 8-bit bytes, that is, the numbers that represent the ASCI code as it applies to a full eight-bit, 256 character set. The code that follows the filling of the bytes() array in each case decides which version of the ASCI character set to deliver. For a hex set of characters, 0-9, and A to F, the total bit set is broken into double the number of four-bit bytes, then returned for use. For the base-64 set, lower case letters, upper case letters, and integers mainly, six bit characters are made for output. These two sets are the most useful here, since they consist of commonly used characters. The 128 and 256 ASCI sets are too full of both exotic and non-printing characters to be useful. For each hash version its bit count is a constant, so the length of its output will vary according to the chosen type.

If your data is in ANSI, you will get different results between Excel/ACCESS and SQL Server when using T-SQL HASHBYTES() function for characters code over 128. To solve those differences use StrConv() instead of .GetBytes_4()

'dont use for ANSI
Set oT = CreateObject("System.Text.UTF8Encoding")
TextToHash = oT.GetBytes_4(sIn)
'for ANSI data use StrConv instead
TextToHash = StrConv(sIn, vbFromUnicode)


Option Explicit

Sub Test()
    'run this to test md5, sha1, sha2/256, sha384, sha2/512 with salt, or sha2/512
    'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
    'and not just Net Advanced Services 
    
    Dim sIn As String, sOut As String, b64 As Boolean
    Dim sH As String, sSecret As String
    
    'insert the text to hash within the sIn quotes
    'and for selected procedures a string for the secret key
    sIn = ""
    sSecret = "" 'secret key for StrToSHA512Salt only
    
    'select as required
    'b64 = False   'output hex
    b64 = True   'output base-64
    
    'enable any one
    'sH = MD5(sIn, b64)
    'sH = SHA1(sIn, b64)
    'sH = SHA256(sIn, b64)
    'sH = SHA384(sIn, b64)
    'sH = StrToSHA512Salt(sIn, sSecret, b64)
    sH = SHA512(sIn, b64)
    
    'message box and immediate window outputs
    Debug.Print sH & vbNewLine & Len(sH) & " characters in length"
    MsgBox sH & vbNewLine & Len(sH) & " characters in length"
    
    'de-comment this block to place the hash in first cell of sheet1
'    With ThisWorkbook.Worksheets("Sheet1").Cells(1, 1)
'        .Font.Name = "Consolas"
'        .Select: Selection.NumberFormat = "@" 'make cell text
'        .Value = sH
'    End With

End Sub

Public Function MD5(ByVal sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
    'and not just Net Advanced Services 
        
    'Test with empty string input:
    'Hex:   d41d8cd98f00...etc
    'Base-64: 1B2M2Y8Asg...etc
        
    Dim oT As Object, oMD5 As Object
    Dim TextToHash() As Byte
    Dim bytes() As Byte
        
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oMD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
 
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oMD5.ComputeHash_2((TextToHash))
 
    If bB64 = True Then
       MD5 = ConvToBase64String(bytes)
    Else
       MD5 = ConvToHexString(bytes)
    End If
        
    Set oT = Nothing
    Set oMD5 = Nothing

End Function

Public Function SHA1(sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
    'and not just Net Advanced Services 
   
   'Test with empty string input:
    '40 Hex:   da39a3ee5e6...etc
    '28 Base-64:   2jmj7l5rSw0yVb...etc
    
    Dim oT As Object, oSHA1 As Object
    Dim TextToHash() As Byte
    Dim bytes() As Byte
            
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA1 = CreateObject("System.Security.Cryptography.SHA1Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA1.ComputeHash_2((TextToHash))
        
    If bB64 = True Then
       SHA1 = ConvToBase64String(bytes)
    Else
       SHA1 = ConvToHexString(bytes)
    End If
            
    Set oT = Nothing
    Set oSHA1 = Nothing
    
End Function

Public Function SHA256(sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
    'and not just Net Advanced Services 
    
    'Test with empty string input:
    '64 Hex:   e3b0c44298f...etc
    '44 Base-64:   47DEQpj8HBSa+/...etc
    
    Dim oT As Object, oSHA256 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA256.ComputeHash_2((TextToHash))
    
    If bB64 = True Then
       SHA256 = ConvToBase64String(bytes)
    Else
       SHA256 = ConvToHexString(bytes)
    End If
    
    Set oT = Nothing
    Set oSHA256 = Nothing
    
End Function

Public Function SHA384(sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
    'and not just Net Advanced Services 
    
    'Test with empty string input:
    '96 Hex:   38b060a751ac...etc
    '64 Base-64:   OLBgp1GsljhM2T...etc
    
    Dim oT As Object, oSHA384 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA384 = CreateObject("System.Security.Cryptography.SHA384Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA384.ComputeHash_2((TextToHash))
    
    If bB64 = True Then
       SHA384 = ConvToBase64String(bytes)
    Else
       SHA384 = ConvToHexString(bytes)
    End If
    
    Set oT = Nothing
    Set oSHA384 = Nothing
    
End Function

Public Function SHA512(sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
    'and not just Net Advanced Services 
    
    'Test with empty string input:
    '128 Hex:   cf83e1357eefb8bd...etc
    '88 Base-64:   z4PhNX7vuL3xVChQ...etc
    
    Dim oT As Object, oSHA512 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA512 = CreateObject("System.Security.Cryptography.SHA512Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA512.ComputeHash_2((TextToHash))
    
    If bB64 = True Then
       SHA512 = ConvToBase64String(bytes)
    Else
       SHA512 = ConvToHexString(bytes)
    End If
    
    Set oT = Nothing
    Set oSHA512 = Nothing
    
End Function

Function StrToSHA512Salt(ByVal sIn As String, ByVal sSecretKey As String, _
                           Optional ByVal b64 As Boolean = False) As String
    'Returns a sha512 STRING HASH in function name, modified by the parameter sSecretKey.
    'This hash differs from that of SHA512 using the SHA512Managed class.
    'HMAC class inputs are hashed twice;first input and key are mixed before hashing,
    'then the key is mixed with the result and hashed again.
    'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
    'and not just Net Advanced Services 
    
    Dim asc As Object, enc As Object
    Dim TextToHash() As Byte
    Dim SecretKey() As Byte
    Dim bytes() As Byte
    
    'Test results with both strings empty:
    '128 Hex:    b936cee86c9f...etc
    '88 Base-64:   uTbO6Gyfh6pd...etc
    
    'create text and crypto objects
    Set asc = CreateObject("System.Text.UTF8Encoding")
    
    'Any of HMACSHAMD5,HMACSHA1,HMACSHA256,HMACSHA384,or HMACSHA512 can be used
    'for corresponding hashes, albeit not matching those of Managed classes.
    Set enc = CreateObject("System.Security.Cryptography.HMACSHA512")

    'make a byte array of the text to hash
    bytes = asc.Getbytes_4(sIn)
    'make a byte array of the private key
    SecretKey = asc.Getbytes_4(sSecretKey)
    'add the private key property to the encryption object
    enc.Key = SecretKey

    'make a byte array of the hash
    bytes = enc.ComputeHash_2((bytes))
    
    'convert the byte array to string
    If b64 = True Then
       StrToSHA512Salt = ConvToBase64String(bytes)
    Else
       StrToSHA512Salt = ConvToHexString(bytes)
    End If
    
    'release object variables
    Set asc = Nothing
    Set enc = Nothing

End Function

Private Function ConvToBase64String(vIn As Variant) As Variant
    'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
    'and not just Net Advanced Services 
   
   Dim oD As Object
      
    Set oD = CreateObject("MSXML2.DOMDocument")
      With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.base64"
        .DocumentElement.nodeTypedValue = vIn
      End With
    ConvToBase64String = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing

End Function

Private Function ConvToHexString(vIn As Variant) As Variant
    'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
    'and not just Net Advanced Services 
    
    Dim oD As Object
      
    Set oD = CreateObject("MSXML2.DOMDocument")
      
      With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.Hex"
        .DocumentElement.nodeTypedValue = vIn
      End With
    ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing

End Function

See Also[edit | edit source]

  • File Hashing in VBA  : A companion page in this series that lists code for single file hashing. Combine this with file listing code for extensive hashing of files.
  • Folder Hashing in VBA :Another companion page that makes recursive folder hash listings, and logs. Uses up to date hash algorithms, but limited to files no larger than about 200MB.


File Hashing in VBA

Summary[edit | edit source]

  • This section contains code for making file hashes, that is, hashes of entire files.
    • Several algorithms are provided, with output options for base64 or hex. The VBA code below generates the digests for the MD5, SHA1, SHA2-256, SHA2-384, and SHA2-512 hashes.
    • The code is made for single files, but the code given on an adjacent page, Folder Hashing in VBA, can be used for recursive hash listings, again with a choice of hashes and output options.
    • String hash routines are given in another section.
    • In general these hashes do not make use of a seed value, but to illustrate the method, the code contains one such example, (FileToSHA512SALT()). Please note that its output differs from that of the SHA512Managed class. A note exists in the respective procedure in case other salted (seeded) inputs are of interest.
    • These listed algorithms can hash any single file up to about 200MB (Mega Bytes) in length, beyond which an out of memory error will be generated in GetFileBytes(). Specific tests found that hashes work well for a 200MB zip file but fail for a 500MB zip file; the exact break point is unclear. For files larger than 200MB, other facilities exist.
  • Large file hashing, say beyond 200MB is best done with other tools. Four such examples are mentioned here:
    • Microsoft's FCIV utility, is free download. It is a command-line application, capable of hashing both single files and whole folder trees. It handles large files with ease, but only for MD5 and SHA1 hashes. It sends both base64 and HEX outputs to the screen but only b64 output format to a file. Prepared files can be verified against any new run, but results only to the screen. It is a bit tricky to use, even with their instructions, so the pages Running the FCIV Utility from VBA and File Checksum Integrity Verifier (FCIV) Examples might be found of use to the novice. So far, Microsoft have not extended the coding to include contemporary algorithms.
    • PowerShell in Windows 8.1 and above, can make large single-file hashes, using all of the MD5. SHA1, SHA256, SHA384, and SHA512 algorithms. It produces output on the screen only, though the output can also be piped to the clipboard for pasting as required. There are no simple options for hashing a folder or for output to an xml file. For completion, an example of its use is given in File Checksum Integrity Verifier (FCIV) Examples. In Windows 10, hashes can also be obtained at the command prompt with certutil -hashfile <full path to file to hash> MD5, though size limitations are unclear. (Change md5 to sha1, sha256, or sha512, etc).
    • An external application that can handle large files is MD5 and SHA Checksum Utility. It is a stand-alone application, and a basic version is available as a free download. It produces MD5, SHA1, SHA2/256, and SHA2/512 hashes for single files. The outputs are in HEX and are displayed together on a neat user interface. A more complex commercial version is also available.
    • FSUM Fast File Integrity Checker is another free, external application for command line use. It resembles FCIV in many ways but includes up to date algorithms. (MD2, MD4, MD5, SHA-1, SHA-2( 256, 384, 512), RIPEMD-160, PANAMA, TIGER, ADLER32, and CRC32). In addition to large file HEX hashes it can carry out flat or recursive folder hashes. The code to enter is not identical to that of FCIV but a text file is provided with examples in its use. The web page FSUM Fast File Integrity Checker has the download and other details, though the text file fails to mention that results can be easily piped to the clipboard with |clip. Although a graphical interface exists elsewhere, the command-line application has been found the most stable..
  • The permissions for files need to be considered when attempting hashing. Hashing has to access files to obtain the bytes that they contain. Although this does not involve actually running the files, some folder and file types might be found locked at run time. In fact, this type of access is the main difference between string hashing and file hashing. Whenever files are accessed, error handling tends to be needed. It is assumed here that the user will add his own error-handling, or that he will go-around files that are troublesome before the hashing attempt. Users should know that the code cannot handle an empty text file; for example, a Notepad file that has been saved without any text in it. The GetFileBytes routine will error. A message and exit will be produced if an empty file is encountered, as for a file in excess of 200MB.
  • User files and folders have few restrictions. The empty file problem apart, those who want to access user files in folders that they have made themselves will not usually have any problems, and interested parties should know that there is a recursive folder hashing module in another section of this series that might be of related interest. Folder Hashing in VBA also contains notes on how to avoid virtual folder problems with music, video, and other Microsoft libraries.
  • Hashing is concerned only with the content of a file, and not its name, or other file details. This means that duplicates of files under any name can be found by comparing their hashes. In secure systems with deliberately confusing file names, this means that a very long file list could be hashed until a searched-for hash value is found, rather than depending on a less secure file name to find it. Alternatively, file names are sometimes just the file's hash value, so that hashing can reveal any error or illegal change. In such a case a hacker might change the file then name the file with a corresponding hash, but he does not know the required hash algorithm or private string to use, so changes will always be detected when the owner runs his own hash verification.

Code Listings[edit | edit source]

IMPORTANT. It was found that the hash routines errored in a Windows 10, 64 bit Office setup. However, subsequent checking revealed the solution. The Windows platform must have intalled the Net Framework 3.5 (includes .Net 2 and .Net 3), this older version, and not only the Net Framework 4.8 Advanced Services that was enabled in Turn Windows Features on and off. When it was selected there, the routines worked perfectly.

Modifications[edit | edit source]

  • Added default code for transfer of results to the clipboard, 11 Sep 2020
  • Set file selection dialog to open with all-file types to be listed, 25 July 2019
  • Added file selection dialog, and file size limits, 17 Jun 2019

Using Built-in Windows Functions in VBA[edit | edit source]

The code to make hashes of STRINGS and for bulk file hashing is given elsewhere in this set. The panel below bears code that is virtually identical to that for strings, but with only slight modification, is used to make hashes of single whole FILES. The user provides a full path to the file via a selection dialog as the starting parameter. A parameter option allows for a choice of hex or base-64 outputs. Functions are included for MD5, SHA1, SHA2-256, SHA2-384, and SHA2-512 hashes.

For frequent use, the selection dialog is most convenient, though the code contains a commented-out line for those who intend to type the file address into the procedure; simply comment out the line not needed.

In each case, coders can find the unmodified hash values in the bytes() array and at that point they are in 8-bit bytes, that is, the numbers that represent the ASCI code as it applies to a full eight-bit, 256 character set. The code that follows the filling of the bytes() array in each case decides which version of the ASCI character set to deliver. For a hex set of characters, 0-9, and A to F, the total bit set is broken into double the number of four-bit bytes, then returned for use. For the base-64 set, lower case letters,upper case letters, and integers mainly, six bit characters are made for output. These two sets are the most useful here, since they consist of commonly used characters. The 128 and 256 ASCI sets are too full of both exotic and non-printing characters to be useful. For each hash version its bit count is a constant, so the length of its output will vary according to the chosen type.

As a general point; message boxes do not allow copying of their text. If copying is needed, replace the message box with an input box, and set the output hash to be the default value of the box. Then it can be copied with ease. Alternatively use the output of the Debug.Print method in the immediate window. A procedure has been included to overwrite the clipboard with the results: If this is not inteded then comment the line out in the top procedure.

Option Explicit
Public sFPath As String, sH As String

Private Sub TestFileHashes()
    'run this to obtain file hashes in a choice of algorithms
    'select any one algorithm call below
    'Limited to unrestricted files less than 200MB and not zero
    'Set a reference to mscorlib 4.0 64-bit, and Microsoft Scripting Runtime
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
        
    Dim b64 As Boolean, bOK As Boolean, bOK2 as Boolean
    Dim sSecret As String, nSize As Long, reply
    
    'USER SETTINGS
    '======================================================
    '======================================================
    'set output format here
    b64 = True     'true for output base-64, false for hex
    '======================================================
    'set chosen file here
    'either set path to target file in hard-typed line
    'or choose a file using the file dialog procedure
    'sFPath = "C:\Users\Your Folder\Documents\test.txt" 'eg.
    sFPath = SelectFile2("SELECT A FILE TO HASH...") 'uses file dialog
        
    'check the file
    If sFPath = "" Then 'exit sub for no file selection
        MsgBox "No selection made - closing"
        Exit Sub
    End If
    bOK = GetFileSize(sFPath, nSize)
    If nSize = 0 Or nSize > 200000000 Then 'exit sub for zero size
        MsgBox "File has zero contents or greater than 200MB - closing"
        Exit Sub
    End If
    '======================================================
    'set secret key here if using HMAC class of algorithms
    sSecret = "Set secret key for FileToSHA512Salt selection"
    '======================================================
    'choose algorithm
    'enable any one line to obtain that hash result
    'sH = FileToMD5(sFPath, b64)
    'sH = FileToSHA1(sFPath, b64)
    'sH = FileToSHA256(sFPath, b64)
    'sH = FileToSHA384(sFPath, b64)
    'sH = FileToSHA512Salt(sFPath, sSecret, b64)
    sH = FileToSHA512(sFPath, b64)
    '======================================================
    '======================================================
    
    'Results Output - open the immediate window as required
    Debug.Print sFPath & vbNewLine & sH & vbNewLine & Len(sH) & " characters in length"
    MsgBox sFPath & vbNewLine & sH & vbNewLine & Len(sH) & " characters in length"
    'reply = InputBox("The selected text can be copied with Ctrl-C", "Output is in the box...", sH)
    
    'decomment these two lines to overwrite the clipboard with the results
    bOK2 = CopyToClip(sH)
    If bOK2 = True Then MsgBox ("The result is on the clipboard.")
    
    'decomment this line to append the hash to a file (after setting its path)
    'AppendHashToFile

'decomment this block to place the hash in first cell of sheet1
'    With ThisWorkbook.Worksheets("Sheet1").Cells(1, 1)
'        .Font.Name = "Consolas"
'        .Select: Selection.NumberFormat = "@" 'make cell text
'        .Value = sH
'    End With
End Sub

Private Sub AppendHashToFile()
    Dim sFPath2 As String, fso As FileSystemObject, ts As TextStream
    Dim sContents As String, sNewContents As String
    
    sFPath2 = "C:\Users\Your Folder\Documents\test.txt" 'eg.
    Set fso = New FileSystemObject
    
    If Not Dir(sFPath2) = vbNullString Then
        'docs.microsoft.com/office/vba/language/reference/user-interface-help/opentextfile-method
        'devblogs.microsoft.com/scripting/how-can-i-add-a-line-to-the-top-of-a-text-file/
        Set ts = fso.OpenTextFile(sFPath2, ForReading)
        sContents = ts.ReadAll: ts.Close
    End If
    
    sNewContents = sH & vbTab & sFPath & vbTab & Now & vbNewLine & sContents
    sNewContents = Left(sNewContents, Len(sNewContents) - 2)
    
    Set ts = fso.OpenTextFile(sFPath2, ForWriting, True)
    ts.WriteLine sNewContents: ts.Close
End Sub

Public Function FileToMD5(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an MD5 hash
    'Set a reference to mscorlib 4.0 64-bit
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
        
    Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath)
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToMD5 = ConvToBase64String(bytes)
    Else
       FileToMD5 = ConvToHexString(bytes)
    End If
        
    Set enc = Nothing

End Function

Public Function FileToSHA1(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an SHA1 hash
    'Set a reference to mscorlib 4.0 64-bit
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
   
   Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToSHA1 = ConvToBase64String(bytes)
    Else
       FileToSHA1 = ConvToHexString(bytes)
    End If
        
    Set enc = Nothing

End Function

Function FileToSHA512Salt(ByVal sPath As String, ByVal sSecretKey As String, _
                           Optional ByVal bB64 As Boolean = False) As String
    'Returns a sha512 FILE HASH in function name, modified by parameter sSecretKey.
    'This hash differs from that of FileToSHA512 using the SHA512Managed class.
    'HMAC class inputs are hashed twice;first input and key are mixed before hashing,
    'then the key is mixed with the result and hashed again.
    'Set a reference to mscorlib 4.0 64-bit
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
    
    Dim asc As Object, enc As Object
    Dim SecretKey() As Byte
    Dim bytes() As Byte
    
    'create a text and crypto objects
    Set asc = CreateObject("System.Text.UTF8Encoding")
    
    'Any of HMACSHAMD5,HMACSHA1,HMACSHA256,HMACSHA384,or HMACSHA512 can be used
    'for corresponding hashes, albeit not matching those of Managed classes.
    Set enc = CreateObject("System.Security.Cryptography.HMACSHA512")

    'make a byte array of the text to hash
    bytes = GetFileBytes(sPath)
    
    'make a byte array of the private key
    SecretKey = asc.Getbytes_4(sSecretKey)
    'add the key property
    enc.Key = SecretKey

    'make a byte array of the hash
    bytes = enc.ComputeHash_2((bytes))
    
    'convert the byte array to string
    If bB64 = True Then
       FileToSHA512Salt = ConvToBase64String(bytes)
    Else
       FileToSHA512Salt = ConvToHexString(bytes)
    End If
    
    'release object variables
    Set asc = Nothing
    Set enc = Nothing

End Function

Public Function FileToSHA256(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an SHA2-256 hash
    'Set a reference to mscorlib 4.0 64-bit
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
    
    Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.SHA256Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToSHA256 = ConvToBase64String(bytes)
    Else
       FileToSHA256 = ConvToHexString(bytes)
    End If
        
    Set enc = Nothing

End Function

Public Function FileToSHA384(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an SHA2-384 hash
    'Set a reference to mscorlib 4.0 64-bit
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
    
    Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.SHA384Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToSHA384 = ConvToBase64String(bytes)
    Else
       FileToSHA384 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing

End Function

Public Function FileToSHA512(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an SHA2-512 hash
    'Set a reference to mscorlib 4.0 64-bit
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
    
    Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.SHA512Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToSHA512 = ConvToBase64String(bytes)
    Else
       FileToSHA512 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing

End Function

Private Function GetFileBytes(ByVal sPath As String) As Byte()
    'makes byte array from file
    'Set a reference to mscorlib 4.0 64-bit
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
    
    Dim lngFileNum As Long, bytRtnVal() As Byte, bTest
    
    lngFileNum = FreeFile
    
    If LenB(Dir(sPath)) Then ''// Does file exist?
        
        Open sPath For Binary Access Read As lngFileNum
        
        'a zero length file content will give error 9 here
        
        ReDim bytRtnVal(0 To LOF(lngFileNum) - 1&) As Byte
        Get lngFileNum, , bytRtnVal
        Close lngFileNum
    Else
        Err.Raise 53 'File not found
    End If
    
    GetFileBytes = bytRtnVal
    
    Erase bytRtnVal

End Function

Function ConvToBase64String(vIn As Variant) As Variant
    'used to produce a base-64 output
    'Set a reference to mscorlib 4.0 64-bit
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
    
    Dim oD As Object
      
    Set oD = CreateObject("MSXML2.DOMDocument")
      With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.base64"
        .DocumentElement.nodeTypedValue = vIn
      End With
    ConvToBase64String = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing

End Function

Function ConvToHexString(vIn As Variant) As Variant
     'used to produce a hex output
    'Set a reference to mscorlib 4.0 64-bit
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
    
    Dim oD As Object
      
    Set oD = CreateObject("MSXML2.DOMDocument")
      
      With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.Hex"
        .DocumentElement.nodeTypedValue = vIn
      End With
    ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing

End Function

Function GetFileSize(sFilePath As String, nSize As Long) As Boolean
    'use this to test for a zero file size
    'takes full path as string in sFilePath
    'returns file size in bytes in nSize
    'Make a reference to Scripting Runtime
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
    
    Dim fs As FileSystemObject, f As File
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FileExists(sFilePath) Then
        Set f = fs.GetFile(sFilePath)
        nSize = f.Size
        GetFileSize = True
        Exit Function
    End If

End Function

Function SelectFile2(Optional sTitle As String = "") As String
    'opens a file-select dialog and on selection
    'returns its full path string in the function name
    'If Cancel or OK without selection, returns empty string
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
   
   Dim fd As FileDialog, sPathOnOpen As String, sOut As String
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    'do not include backslash here
    sPathOnOpen = Application.DefaultFilePath
    
    'set the file-types list on the dialog and other properties
    With fd
        .Filters.Clear
        'the first filter line below sets the default on open (here all files are listed)
        .Filters.Add "All Files", "*.*"
        .Filters.Add "Excel workbooks", "*.xlsx;*.xlsm;*.xls;*.xltx;*.xltm;*.xlt;*.xml;*.ods"
        .Filters.Add "Word documents", "*.docx;*.docm;*.dotx;*.dotm;*.doc;*.dot;*.odt"
                
        .AllowMultiSelect = False
        .InitialFileName = sPathOnOpen
        .Title = sTitle
        .InitialView = msoFileDialogViewList 'msoFileDialogViewSmallIcons
        .Show
        
        If .SelectedItems.Count = 0 Then
            'MsgBox "Canceled without selection"
            Exit Function
        Else
            sOut = .SelectedItems(1)
            'MsgBox sOut
        End If
    End With
    
    SelectFile2 = sOut

End Function

Function CopyToClip(sIn As String) As Boolean
    'passes the parameter string to the clipboard
    'set reference to Microsoft Forms 2.0 Object Library (by browsing for FM20.DLL).
    'If ref not listed, inserting user form will list it.
    'Clipboard cleared when launch application closes.
    'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
    'and not only the Net Framework 4.8 Advanced Services
    
    Dim DataOut As DataObject
    
    Set DataOut = New DataObject
    
    'first pass textbox text to dataobject
    DataOut.SetText sIn
    
    'then pass dataobject text to clipboard
    DataOut.PutInClipboard
    
    'release object variable
    Set DataOut = Nothing
    
    CopyToClip = True
    
End Function

See Also[edit | edit source]

  • String Hashing in VBA : A companion page in this series for those who want only to hash strings.
  • Folder Hashing in VBA :Another companion page that makes recursive folder hash listings, and logs. Uses up to date hash algorithms, but limited to files no larger than about 200MB.
  • Running the FCIV Utility from VBA: How to use the Microsoft fciv.exe command line utility to make MD5 and SHA1 file hashes from VBA. The MS utility, although awkward to use, allows hashing and verification of entire folder trees.
  • File Checksum Integrity Verifier (FCIV) Examples: More details on how to use the FCIV utility for those without much experience working from the command line prompt.

External Links[edit | edit source]

  • MD5 and SHA Checksum Utility: a external site's free application to simultaneously display MD5,SHA1,SHA256,and SHA512 hashes of single files (Hex only). Includes a browse-for-file function and drag and drop to make life easy. This utility can also be used to hash large files; author-tested for a 500MB file.
  • FSUM Fast File Integrity Checker : The basic command-line version of the FSUM hasher download.
  • FSUM GUI : A graphical interface download site for the FSUM utility. This allows file browsing, drag and drop, and other facilities to simplify the otherwise command-line working.


Folder Hashing in VBA

Summary[edit | edit source]

Figure 1: The user form for the project. The names of controls correspond to those used in the code modules. The frames that contain OptionButtons must exist, but the frame names are arbitrary. Click the image for an enlarged view.
  • These modules are made for Microsoft Excel only. It hashes files in whole folders. It handles both flat and recursive folder listing, makes log files, and verifies files against hash files made previously.
  • Any of five hash algorithms can be used on the worksheet. They are, MD5, SHA1, SHA256, SHA384, and SHA512,. They are displayed on Sheet1 of the workbook in either hex or base64 formats. If log files are also required for these hashes, they are made in SHA512-b64 format for future verification; this format is independent of the format chosen for worksheet listings.
  • Verification results appear on Sheet2 of the workbook. Verification failures are highlighted in red. Make sure therefore that Sheet1 and Sheet2 exist in the workbook. These results can also be delivered to a log file for future use.
  • Log files, when made, are found in the default folder. Make log choices on the user form's check box options.
    • HashFile*.txt logs have a name that is date-stamped, and contains the number of files listed in it. Separate logs can be made for each run.
    • HashErr.txt is the error log. It logs file item paths that could not be hashed. There is only one of these, and the results for each run are appended with a date-time stamp. When full, just delete it and a new one will be made as required.
    • VerReport*.txt logs a copy of verification results. A separate log can be made for each verification run. It too has a date-time stamp in its file name.
  • The process is slower than FCIV, but has more algorithms to choose from. However, unlike FCIV no single file can exceed about 200MB. See File Hashing in VBA for notes on ways to hash larger files. A recursive run of the Documents folder, (2091 user files, and 1.13GB in total), took seven and a half minutes. It included writing to the worksheet, making a hash log, and logging 36 filter exclusions in an error file. Verification is faster, taking about half of that time.
  • A user form layout is shown in Figure 1. The exact control names are given, and these correspond exactly to those in code. The use of the same control names is essential for a trouble-free installation. Regrettably, there is no way in Wikibooks to download an Excel file, or for that matter the VBA code files themselves, so the main work is in the making of the user form.
  • Set filter conditions in FilterOK(). The fastest results can be had when the filter conditions are as narrow as possible. A wide range of filter conditions can be set directly in code, and for items filtered, their paths will be listed in the error file.
  • Be sure to set VBA Project references. Required are Visual Basic for Applications Extensibility 5.3, mscorlib.dll, and Microsoft Scripting Runtime, in addition to any others that you may require. The VBA editor's error setting should be Break on Unhandled Errors.
  • My Documents versus Documents. There are four virtual folders in the Libraries category of the Windows Explorer, My Documents, My Music, My Pictures, and My Videos. When the Windows Explorer's Folder Options are set to NOT display hidden files, folders, drives and Operating system files, the correct locations are nonetheless returned by the folder selection dialogs, namely Documents, Music, Pictures, and Videos. When there are NO restrictions on viewing hidden and operating system files and folders, then selection dialogs will wrongly attempt to return these virtual paths, and access violations will result. It is only by avoiding this situation that easy listings can be obtained, so check that the Folder Options of Windows Explorer are set in accordance with Figure 2.

The Code Modules[edit | edit source]

File:Folder Options.png
Figure 2: Denied access to files can be avoided in part by ensuring that operating system files are not shown. The use of these settings will avoid many problems.

IMPORTANT. It was found that the hash routines errored in a Windows 10, 64 bit Office setup. However, subsequent checking revealed the solution. The Windows platform must have intalled the Net Framework 3.5 (includes .Net 2 and .Net 3), this older version, and not only the Net Framework 4.8 Advanced Services that was enabled in Turn Windows Features on and off. When it was selected there, the routines worked perfectly.

There are three modules to consider; the ThisWorkbook module, that contains the code to run automatically at startup; the Userform1 module, that contains the code for the controls themselves, and the main Module1 code that contains everything else.

  • Make sure that Sheet1 and Sheet2 exist on the workbook.
  • Then, make a user form called UserForm1, carefully using the same names as the controls in Figure 1, and in exactly the same places. Set the UserForm1 as non-modal in its properties. Save the Excel file with an *.xlsm suffix.
  • Double click the UserForm1, (not a control), in design mode, to open the code module associated with it, then copy the respective code block into it. Save the Excel file. (Saving the file in the VBE editor is exactly the same as saving on the workbook.)
  • Insert a standard module, and copy the main code listing into it. Save the file.
  • Lastly, when all other work is done, transfer the ThisWorkbook code, and save the file.
  • Set the Windows Explorer folder options in accordance with Figure 2.
  • Close the Excel workbook, then reopen it to be display the user form. If the user form is closed for any reason, it can be re-opened by running the Private Sub Workbook_Open() procedure in the ThisWorkbook module. (ie: Place cursor in the procedure then press F5.)

Using the App[edit | edit source]

There are two main functions; making hashes on the worksheet and an optional hash log, and verifying computer folders against a previously made hash log. The hashing mode also includes an optional error log, to list both errors and files avoided by the user-set filters. Verification results use an optional log of their own. Be sure to note the required Folder Options of Figure 2 before any hashing activities.

Making hashes[edit | edit source]

  • Set the options, recursion, output format, and hash algorithm in the topmost panel. Make log file selections on the check boxes.
  • Select a folder to hash with Select Folder to Hash. Then, pressing the Hash Folder button starts the listing on Sheet1 of the workbook.
  • Wait for the run to finish. The user form's top-caption changes to advise that the application is still processing, and message boxes advise when the run is complete. The Stop all Code button can be pressed at any time to return to the VBA editor in either of the two working modes.
  • Filtered files will be ignored in hashing. These are files deliberately avoided by user settings in the FilterOK() procedure. Such files will be listed in the error file (HashErr*.txt), if selected.
  • Log files are available for inspection, if such options were selected, located most often in the workbook's launch folder.
  • Restrict hashing to user libraries. Owing to the large numbers of hidden and otherwise restricted files in Windows, it is recommended that hashing be restricted to the contents of the user profiles. Although some files will be restricted even there, for most this is not much of a limitation, since it still includes Documents, Downloads, Music, Pictures, and Videos, and various other folders.

Verifying Folders[edit | edit source]

The verification process verifies only those file paths that are listed on the chosen hash file, and will not even consider files added to the file folders since the hash file was made. When folders are changed, new hash files need to be made in a working system.

  • Make a file selection in the bottom panel, by pressing Select File to Verify. This must be a log file (HashFile*.txt) made at an earlier time for the purpose of verification. It is the same file that can be made during a hash run, and regardless of any settings made for worksheet listing, these files will always be made as SHA512-b64 format.
  • Press Start Verification to start the process. Results are listed on Sheet2 of the worksheet, and any failures are color-highlighted. The user form caption changes to advise that the application is still processing, and message boxes advise when the process is complete.
  • Review the results , either on Sheet2 or in the verification results file (VerHash*.txt) in the default folder. Consider further action.

Code Modification Notes[edit | edit source]

  • Code modified 17 Oct 20, replaced the API version of folder selection with one that is independent of 32 or 64 bit working
  • Code modified 28 Jan 19, modified SelectFile(), to set All Files as default display.
  • Code modified 9 Dec 18, corrected CommandButton6_Click(), one entry wrongly marked sSht instead of oSht.
  • Code modified 5 Dec 18, corrected Module1, code error in initializing public variables.
  • Code modified 5 Dec 18, updated Module1 and UserForm1 for improved status bar reporting and sheet1 col E heading.
  • Code modified 4 Dec 18, updated Module1 and UserForm1 for more responsive output and reporting improvements.
  • Code modified 2 Dec 18, updated Module1 for error reporting improvements, and GetFileSize() larger file reporting.
  • Code modified 1 Dec 18, corrected Module1 and UserForm1 for error log issues.
  • Code modified 30 Nov 18, updated to provide algorithm selection and a new userform layout.
  • Code modified 23 Nov 18, corrected sheet number error, format all code, and remove redundant variables.
  • Code modified 23 Nov 18 updated to add verification and a new userform layout.
  • Code modified 21 Nov 18 updated to add error logging and hash logging.

ThisWorkbook Module[edit | edit source]

Private Sub Workbook_Open()
   'displays userform for
   'options and running
   
   Load UserForm1
   UserForm1.Show

End Sub

The Userform1 Module[edit | edit source]

Option Explicit
Option Compare Binary 'default,important

Private Sub CommandButton1_Click()
    'opens and returns a FOLDER path
    'using the BrowseFolderExplorer() dialog
    'Used to access the top folder for hashing
    
    'select folder
    sTargetPath = BrowseFolderExplorer("Select a folder to list...", 0)
    
    'test for cancel or closed without selection
    If sTargetPath <> "" Then
        Label2.Caption = sTargetPath 'update label with path
    Else
        Label2.Caption = "No folder selected"
        sTargetPath = ""  'public
        Exit Sub
    End If
'option compare
End Sub

Private Sub CommandButton2_Click()
    'Pauses the running code
    'Works best in combination with DoEvents
    
    MsgBox "To fully reset the code, the user should first close this message box," & vbCrLf & _
    "then select RESET on the RUN drop-menu item of the VBE editor..." & vbCrLf & _
    "If not reset, it can be started again where it paused with CONTINUE.", , "The VBA code has paused temporarily..."
    Stop
    
End Sub

Private Sub CommandButton3_Click()
    'starts the hashing run in
    'HashFolder() via RunFileListing()
    
    Dim bIsRecursive As Boolean
        
    'flat folder or recursive options
    If OptionButton2 = True Then
        bIsRecursive = True
    Else
        bIsRecursive = False
    End If
    
    'test that a folder has been selected before listing
    If Label2.Caption = "No folder selected" Or Label2.Caption = "" Then
        'no path was established
        MsgBox "First select a folder for the listing."
        Me.Caption = "Folder Hasher...Ready..."
        'Me.Repaint
        Exit Sub
    Else
        'label
        Me.Caption = "Folder Hasher...Processing...please wait."
        'make the file and hash listing
        RunFileListing sTargetPath, bIsRecursive
        Me.Caption = "Folder Hasher...Ready..."
        'Me.Repaint
    End If
    
End Sub

Private Sub CommandButton5_Click()
    'opens and returns a file path
    'using the SelectFile dialog.
    'Used to access a stored hash file
    'for a Verification run
    
    sVerifyFilePath = SelectFile("Select the file to use for Verification...")
    
    If sVerifyFilePath <> "" Then
        Label3.Caption = sVerifyFilePath
    Else
        'MsgBox "Cancelled listing"
        Label3.Caption = "No file selected"
        sVerifyFilePath = ""  'public
        Exit Sub
    End If
    
End Sub

Private Sub CommandButton6_Click()
    'runs the verification process
    'compares stored hashes with hashes made now
    'Compares case sensitive. Internal HEX is lower case a-f and integers.
    'Internal Base64 is upper letters, lower letters and integers.
        
    Dim bOK As Boolean, sAllFileText As String, vL As Variant
    Dim nLine As Long, vF As Variant, sHashPath As String, bNoPath As Boolean
    Dim sOldHash As String, sNewHash64 As String, StartTime As Single
    Dim sVerReport As String, oSht As Worksheet
    
    'format of hash files is as follows
    'path,sha512 ... ie; two fields, comma separated
    'one record per line, each line ending in a line break (vbcrlf)
    
    'fetch string from file
    If Label3.Caption = "No file selected" Or Label3.Caption = "" Then
        MsgBox "First select a file for verification"
        Exit Sub
    ElseIf GetFileSize(sVerifyFilePath) = 0 Then
        MsgBox "File contains no records"
        Exit Sub
    Else:
        bOK = GetAllFileText(sVerifyFilePath, sAllFileText)
    End If
    
    'get the system timer value
    StartTime = Timer
    
    Me.Caption = "Folder Hasher...Processing...please wait."
    
    'prepare the worksheet
    Set oSht = ThisWorkbook.Worksheets("Sheet2")
    ClearSheetContents "Sheet2"
    ClearSheetFormats "Sheet2"
    
    'split into lines -split is zero based
    vL = Split(sAllFileText, vbNewLine)
    
    'then for each line
    For nLine = LBound(vL) To UBound(vL) - 1
        DoEvents 'submit to system command stack
        'now split each line into fields on commas
        vF = Split(vL(nLine), ",")
        'obtain the path to hash from first field
        sHashPath = vF(0) 'split is zero based
        sOldHash = vF(1) 'read from file field
        
        'Check whether or not the path on the hash file exists
        bNoPath = False
        If FilePathExists(sHashPath) Then
            sNewHash64 = FileToSHA512(sHashPath, True) 'sha512-b64
        Else
            'record fact on verification report
            bNoPath = True
        End If
        
        oSht.Activate
        oSht.Cells(nLine + 2, 2) = sHashPath  'file path col 2
        If bNoPath = False Then 'the entry is for a valid path
            'if sOldHash is same as sNewHash64 then the file is verified - else not
            'prepare a verification string for filing and output line by line to worksheet
            'Debug.Print sOldHash
            'Debug.Print sNewHash64
            If sOldHash = sNewHash64 Then
                sVerReport = sVerReport & "VERIFIED OK , " & sHashPath & vbCrLf
                'export to the worksheet
                oSht.Cells(nLine + 2, 1) = "VERIFIED OK"
            Else:
                sVerReport = sVerReport & "FAILED MATCH, " & sHashPath & vbCrLf
                oSht.Cells(nLine + 2, 1) = "FAILED MATCH"
                oSht.rows(nLine + 2).Cells.Interior.Pattern = xlNone
                oSht.Cells(nLine + 2, 1).Interior.Color = RGB(227, 80, 57) 'orange-red
                oSht.Cells(nLine + 2, 2).Interior.Color = RGB(227, 80, 57) 'orange-red
            End If
        Else     'the entry is for an invalid path ie; since moved.
            sVerReport = sVerReport & "PATH NOT FOUND, " & sHashPath & vbCrLf
            oSht.Cells(nLine + 2, 1) = "PATH NOT FOUND"
            oSht.rows(nLine + 2).Cells.Interior.Pattern = xlNone
            oSht.Cells(nLine + 2, 1).Interior.Color = RGB(227, 80, 57) 'orange-red
            oSht.Cells(nLine + 2, 2).Interior.Color = RGB(227, 80, 57) 'orange-red
        End If
        
    Next nLine
    
    FormatColumnsAToB ("Sheet2")
    
    'export the report to a file
    bOK = False
    If CheckBox3 = True Then
        bOK = MakeHashLog(sVerReport, "VerReport")
    End If
    
    Me.Caption = "Folder Hasher...Ready..."
    
    'get the system timer value
    EndTime = Timer
    
    If bOK Then
        MsgBox "Verification results are on Sheet2" & vbCrLf & "and a verification log was made." & vbCrLf & _
        "The verification took " & Round((EndTime - StartTime), 2) & " seconds"
    Else
        MsgBox "Verification results are on Sheet2" & vbCrLf & _
        "The verification took " & Round((EndTime - StartTime), 2) & " seconds"
    End If
    
    Set oSht = Nothing

End Sub

Private Sub UserForm_Initialize()
    'initializes Userform1 variables
    'between form load and form show
    
    Me.Caption = "Folder Hasher...Ready..."
    OptionButton2 = True 'recursive listing default
    OptionButton3 = True 'hex output default
    OptionButton9 = True 'sha512 worksheet default
    Label2.Caption = "No folder selected"
    Label3.Caption = "No file selected"
    CheckBox1 = False 'no log
    CheckBox2 = False 'no log
    CheckBox3 = False 'no log
End Sub

The Standard Module1[edit | edit source]

Option Explicit
Option Base 1
Option Private Module
Option Compare Text 'important

Public sht1 As Worksheet          'hash results
Public StartTime As Single        'timer start
Public EndTime As Single          'timer end
Public sTargetPath As String      'selected hash folder
Public sVerifyFilePath As String  'selected verify file
Public sErrors As String          'accum output error string
Public sRecord As String          'accum output hash string
Public nErrors As Long            'accum number hash errors
Public nFilesHashed As Long       'accum number hashed files

Function BrowseFolderExplorer(Optional DialogTitle As String, _
    Optional ViewType As MsoFileDialogView = _
        MsoFileDialogView.msoFileDialogViewSmallIcons, _
    Optional InitialDirectory As String) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' BrowseFolderExplorer
' This provides an Explorer-like Folder Open dialog.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim fDialog  As Office.FileDialog
    Dim varFile As Variant
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    'fDialog.InitialView = ViewType
    With fDialog
        If Dir(InitialDirectory, vbDirectory) <> vbNullString Then
            .InitialFileName = InitialDirectory
        Else
            .InitialFileName = CurDir
        End If
        .Title = DialogTitle
        
        If .Show = True Then
            ' user picked a folder
            BrowseFolderExplorer = .SelectedItems(1)
        Else
            ' user cancelled
            BrowseFolderExplorer = vbNullString
        End If
    End With
End Function

Sub RunFileListing(sFolder As String, Optional ByVal bRecursive As Boolean = True)
    'Runs HashFolder() after worksheet prep
    'then handles output messages to user
    
    'initialize file-counting and error counting variables
    nFilesHashed = 0   'public
    nErrors = 0        'public
    sErrors = ""       'public
    sRecord = ""       'public
    StartTime = Timer  'public
    nFilesHashed = 0   'public
    
    'initialise and clear sheet1
    Set sht1 = ThisWorkbook.Worksheets("Sheet1")
    sht1.Activate
    ClearSheetContents "Sheet1"
    ClearSheetFormats "Sheet1"
    'insert sheet1 headings
    With sht1
        .Range("a1").Formula = "File Path:"
        .Range("b1").Formula = "File Size:"
        .Range("c1").Formula = "Date Created:"
        .Range("d1").Formula = "Date Last Modified:"
        .Range("e1").Formula = Algorithm 'function
        .Range("A1:E1").Font.Bold = True
        .Range("A2:E20000").Font.Bold = False
        .Range("A2:E20000").Font.Name = "Consolas"
    End With
    
    'Run the main listing procedure
    'This outputs to sheet1
    HashFolder sFolder, bRecursive
    
    'autofit sheet1 columns A to E
    With sht1
        .Range("A1").Select
        .Columns("A:E").AutoFit
        .Range("A1").Select
        .Cells.FormatConditions.Delete 'reset any conditional formatting
    End With
    
    'get the end time for the hash run
    EndTime = Timer
    
    'MAKE LOGS AS REQUIRED AND ISSUE COMPLETION MESSAGES
    Select Case nFilesHashed 'the public file counter
    Case Is <= 0 'no files hashed but still consider need for error log
        'no files hashed, errors found, error log requested
        If nErrors <> 0 And UserForm1.CheckBox2 = True Then
            '------------------------------------------------------------
            MakeErrorLog sErrors  'make an error log
            '------------------------------------------------------------
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No hashes made." & vbCrLf & nErrors & " errors noted and logged."
            'no files hashed, errors found, error log not requested
        ElseIf nErrors <> 0 And UserForm1.CheckBox2 = False Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No hashes made." & vbCrLf & nErrors & " errors noted but unlogged."
            'no files hashed, no errors found, no error log made regardless requested
        ElseIf nErrors = 0 Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No hashes made." & vbCrLf & "Error free."
        End If
    Case Is > 0 'files were hashed
        'files were hashed, hash log requested
        If UserForm1.CheckBox1 = True Then
            '------------------------------------------------------------
            MakeHashLog sRecord, "HashFile"  'make a hash log
            '------------------------------------------------------------
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "A log file of these hashes was made."
            'files were hashed, no hash log requested
        Else
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No log file of these hashes was made."
        End If
        'make error files as required
        'files were hashed, errors found, error log requested
        If nErrors <> 0 And UserForm1.CheckBox2 = True Then
            '------------------------------------------------------------
            MakeErrorLog sErrors  'make an error log
            '------------------------------------------------------------
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox nFilesHashed & " hashes to Sheet1." & vbCrLf & nErrors & " errors noted and logged."
            'files were hashed, errors found, error log not requested
        ElseIf nErrors <> 0 And UserForm1.CheckBox2 = False Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox nFilesHashed & " hashes to Sheet1." & vbCrLf & nErrors & " errors noted but unlogged."
            'files were hashed, no errors found, no error log made regardless requested
        ElseIf nErrors = 0 Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox nFilesHashed & " hashes to Sheet1." & vbCrLf & " Error free."
        End If
    End Select
    
    'reset file counting and error counting variables
    nFilesHashed = 0   'public
    nErrors = 0
    
    'caption for completion
    UserForm1.Caption = "Folder Hasher...Ready..."
    
    'time for the hash run itself
    MsgBox "Hashes took " & Round(EndTime - StartTime, 2) & " seconds."
    
    'reset status bar
    Application.StatusBar = ""
    
    Set sht1 = Nothing

End Sub

Sub HashFolder(ByVal SourceFolderName As String, IncludeSubfolders As Boolean)
    'Called by RunFileListing() to prepare hash strings blocks for output.
    'IncludeSubfolders true for recursive listing; else flat listing of first folder only
    'b64 true for base64 output format, else hex output
    'Choice of five hash algorithms set on userform options
    'Hash log always uses sha512-b64, regardless of sheet1 algorithm selections
    'File types, inclusions and exclusions are set in FilterOK()
    
    Dim FSO As Object, SourceFolder As Object, sSuff As String, vS As Variant
    Dim SubFolder As Object, FileItem As Object, sPath As String, sReason As String
    Dim m As Long, sTemp As String, nErr As Long, nNextRow As Long
        
    'm counts accumulated file items hashed - it starts each proc run as zero.
    'nFilesHashed (public) stores accumulated value of m to that point, at the end
    'of each iteration. nErr accumulates items not hashed as errors, with nErrors
    'as its public storage variable.
    
    'transfer accumulated hash count to m on every iteration
    m = m + nFilesHashed 'file count
    nErr = nErr + nErrors 'error count
        
    On Error GoTo Errorhandler
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    
    For Each FileItem In SourceFolder.Files
        DoEvents 'permits running of system commands- ie interruption
        sTemp = CStr(FileItem.Name)
        sPath = CStr(FileItem.path)
        vS = Split(CStr(FileItem.Name), "."): sSuff = vS(UBound(vS))
        
        'Raise errors for testing handler and error log here
        'If sTemp = "test.txt" Then Err.Raise 53   'Stop
        
        'running hash count and running error count to status bar
        Application.StatusBar = "Processing...Files Hashed: " & _
                                 m & " : Not Hashed: " & nErr
        
        'Decide which files are listed FilterOK()
        If FilterOK(sTemp, sPath, sReason) And Not FileItem Is Nothing Then
            m = m + 1 'increment file count within current folder
                    
            'get next sht1 row number - row one already filled with labels
            nNextRow = sht1.Range("A" & rows.Count).End(xlUp).Row + 1
            
            'send current file data and hash to worksheet
            sht1.Cells(nNextRow, 1) = CStr(FileItem.path)
            sht1.Cells(nNextRow, 2) = CLng(FileItem.Size)
            sht1.Cells(nNextRow, 3) = CDate(FileItem.DateCreated)
            sht1.Cells(nNextRow, 4) = CDate(FileItem.DateLastModified)
            sht1.Cells(nNextRow, 5) = HashString(sPath)
            
            'accumulate in string for later hash log
            'This is always sha512-b64 for consistency
            sRecord = sRecord & CStr(FileItem.path) & _
            "," & FileToSHA512(sPath, True) & vbCrLf
        
        'accumulate in string for later error log
        'for items excluded by filters
        Else
            sErrors = sErrors & FileItem.path & vbCrLf & _
            "USER FILTER: " & sReason & vbCrLf & vbCrLf
            nErr = nErr + 1   'increment error counter
        End If
    Next FileItem
    
    'increment public counter with total sourcefolder count
    nFilesHashed = m 'public nFilesHashed stores between iterations
    nErrors = nErr 'public nErrors stores between iterations
    
    'this section performs the recursion of the main procedure
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            HashFolder SubFolder.path, True
        Next SubFolder
    End If
    
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    Exit Sub
    
Errorhandler:
    If Err.Number <> 0 Then
        'de-comment message box lines for more general debugging
        
        'MsgBox "When m = " & m & " in FilesToArray" & vbCrLf & _
        "Error Number :  " & Err.Number & vbCrLf & _
        "Error Description :  " & Err.Description
        
        'accumulate in string for later error log
        'for unhandled errors during resumed working
        If sPath <> "" Then   'identify path for error log
            sErrors = sErrors & sPath & vbCrLf & Err.Description & _
            " (ERR " & Err.Number & " )" & vbCrLf & vbCrLf
        Else    'note that no path is available
            sErrors = sErrors & "NO PATH COULD BE SET" & vbCrLf & _
            Err.Description & " (ERR " & Err.Number & " )" & vbCrLf & vbCrLf
        End If
        
        nErr = nErr + 1       'increment error counter
        Err.Clear             'clear the error
        Resume Next           'resume listing but errors are logged
    End If
    
End Sub

Function FilterOK(sfilename As String, sFullPath As String, sCause As String) As Boolean
    'Returns true if the file passes all tests, else false:  Early exit on test failure.
    
    'CURRENT FILTER TESTS - Keep up to date and change these in SET USER OPTIONS below.
    'Must be included in a list of permitted file types. Can be set to "all" files.
    'File type must not be specifically excluded, for example *.bak.
    'File prefix must not be specifically excluded, for example ~ for some backup files.
    'Path must not include a specified safety string in any location, eg. "MEXSIKOE", "SAFE"
    'Must not have a hidden or system file attribute set.
    'Must not have file size zero bytes (empty text file), or greater than 200 M Bytes.
    
    Dim c As Long, vP As Variant, sPrefTypes As String, bBadAttrib As Boolean
    Dim sAll As String, bExcluded As Boolean, bKeyword As Boolean, bHiddSys As Boolean
    Dim bPrefix As Boolean, bIncluded As Boolean, vPre As Variant, bSizeLimits As Boolean
    Dim sProtected As String, vK As Variant, bTest As Boolean, vInc As Variant
    Dim sExcel As String, sWord As String, sText As String, sPDF As String, sEmail As String
    Dim sVBA As String, sImage As String, sAllUser As String, vExc As Variant, nBites As Double
    Dim sFSuff As String, sIncTypes As String, sExcTypes As String, sPPoint As String
    
    'Input Conditioning
    If sfilename = "" Or sFullPath = "" Then
        'MsgBox "File name or path missing in FilterOK - closing."
        Exit Function
    Else
    End If
    
    'ASSIGNMENTS
    'SOME SUFFIX GROUP FILTER DEFINITIONS
    
    'Excel File List
    sExcel = "xl,xlsx,xlsm,xlsb,xlam,xltx,xltm,xls,xlt,xlm,xlw"
    
    'Word File List
    sWord = "docx,docm,dotx,dotm,doc,dot"
    
    'Powerpoint file list
    sPPoint = "ppt,pot,pps,pptx,pptm,potx,potm,ppam,ppsx,ppsm,sldx,sldm"
    
    'Email common list
    sEmail = "eml,msg,mbox,email,nws,mbs"
    
    'Text File List
    sText = "adr,rtf,docx,odt,txt,css,htm,html,xml,log,err"
    
    'PDF File List
    sPDF = "pdf"
    
    'VBA Code Files
    sVBA = "bas,cls,frm,frx"
    
    'Image File List
    sImage = "png,jpg,jpeg,gif,dib,bmp,jpe,jfif,ico,tif,tiff"
    
    'All User Files Added:
    'the list of all files that could be considered...
    
    'a longer list of common user files - add to it or subtract as required
    sAllUser = "xl,xlsx,xlsm,xlsb,xlam,xltx,xltm,xls,xlt,xlm,xlw," & _
    "docx,docm,dotx,dotm,doc,dot,adr,rtf,docx,odt,txt,css," & _
    "ppt,pot,pps,pptx,pptm,potx,potm,ppam,ppsx,ppsm,sldx,sldm," & _
    "htm,html,xml,log,err,pdf,bas,cls,frm,frx,png,jpg," & _
    "jpeg,gif,dib,bmp,jpe,jfif,ico,tif,tiff,zip,exe,log"
    
    sAll = ""  'using this will attempt listing EVERY file if no other restrictions
    
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    'SET USER FILTER OPTIONS HERE - comma separated items in a string
    'or concatenate existing sets with a further comma string between them.
    'For example:   sIncTypes = ""                        'all types
    'sIncTypes = "log,txt"                 'just these two
    'sIncTypes = sExcel & "," & "log,txt"  'these two and excel
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    
    'RESTRICT FILE TYPES WITH sIncTypes assignment
    'Eg sIncTypes = sWord & "," & sExcel  or for no restriction
    'use sAll or an empty string.
    
    sIncTypes = sAll 'choose other strings for fastest working
    
    'FURTHER SPECIFICALLY EXCLUDE THESE FILE TYPES
    'these are removed from the sIncTypes set, eg: "bas,frx,cls,frm"
    'empty string for none specified
    
    sExcTypes = ""       'empty string for no specific restriction
    
    'SPECIFICALLY EXCLUDE FILES WITH THIS PREFIX
    'eg "~", the tilde etc.
    'empty string means none specified
    
    sPrefTypes = "~"      'empty string for no specific restriction
    
    'SPECIFICALLY EXCLUDE FILE PATHS THAT CONTAIN ANY OF THESE SAFE STRINGS
    'add to the list as required
    
    sProtected = "SAFE,KEEP"   'such files are not listed
    
    'SPECIFICALLY EXCLUDE SYSTEM AND HIDDEN FILES
    'Set bHiddSys to true to exclude these files, else false
    
    bHiddSys = True  'exclude files with these attributes set
    
    'DEFAULT ENTRY- AVOIDS EMPTY FILES
    'Set bNoEmpties to true unless testing
    
    bSizeLimits = True
    
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    'END OF USER FILTER OPTIONS
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    
    'Working
    FilterOK = False
    bExcluded = False
    bIncluded = False
    bPrefix = False
    bKeyword = False
    
    'get the target file name suffix
    vP = Split(sfilename, ".")
    sFSuff = LCase(vP(UBound(vP))) 'work lower case comparison
    
NotBigSmall:
    'specifically exclude any empty files
    'that is, with zero bytes content
    If bSizeLimits = True Then 'check for empty files
        nBites = GetFileSize(sFullPath) 'nBites must be double
        
        If nBites = 0 Or nBites > 200000000 Then 'found one
            Select Case nBites
            Case 0
                sCause = "Zero Bytes"
            Case Is > 200000000
                sCause = "> 200MBytes"
            End Select
            FilterOK = False
            Exit Function
        End If
    End If
    
ExcludedSuffix:
    'make an array of EXCLUDED suffices
    'exit with bExcluded true if any match the target
    'or false if sExcTypes contains the empty string
    If sExcTypes = "" Then 'none excluded
        bExcluded = False
    Else
        vExc = Split(sExcTypes, ",")
        For c = LBound(vExc) To UBound(vExc)
            If sFSuff = LCase(vExc(c)) And vExc(c) <> "" Then
                bExcluded = True
                sCause = "Excluded Type"
                FilterOK = False
                Exit Function
            End If
        Next c
    End If
    
ExcludedAttrib:
    'find whether file is 'hidden' or 'system' marked
    If bHiddSys = True Then 'user excludes these
        bBadAttrib = HiddenOrSystem(sFullPath)
        If bBadAttrib Then
            sCause = "Hidden or System File"
            FilterOK = False
            Exit Function
        End If
    Else   'user does not exclude these
        bBadAttrib = False
    End If
    
Included:
    'make an array of INCLUDED suffices
    'exit with bIncluded true if any match the target
    'or if sIncTypes contains the empty string
    If sIncTypes = "" Then 'all are included
        bIncluded = True
    Else
        vInc = Split(sIncTypes, ",")
        For c = LBound(vInc) To UBound(vInc)
            If sFSuff = LCase(vInc(c)) And vInc(c) <> "" Then
                bIncluded = True
            End If
        Next c
        If bIncluded = False Then 'no match in whole list
            sCause = "Not in Main Set"
            FilterOK = False
            Exit Function
        End If
    End If
    
Prefices:
    'make an array of illegal PREFICES
    'exit with bPrefix true if any match the target
    'or false if sPrefTypes contains the empty string
    If sPrefTypes = "" Then 'none are excluded
        bPrefix = False 'no offending item found
    Else
        vPre = Split(sPrefTypes, ",")
        For c = LBound(vPre) To UBound(vPre)
            If Left(sfilename, 1) = LCase(vPre(c)) And vPre(c) <> "" Then
                bPrefix = True
                sCause = "Excluded Prefix"
                FilterOK = False
                Exit Function
            End If
        Next c
    End If
    
Keywords:
    'make an array of keywords
    'exit with bKeyword true if one is found in path
    'or false if sProtected contains the empty string
    If sProtected = "" Then 'then there are no safety words
        bKeyword = False
    Else
        vK = Split(sProtected, ",")
        For c = LBound(vK) To UBound(vK)
            bTest = sFullPath Like "*" & vK(c) & "*"
            If bTest = True Then
                bKeyword = True
                sCause = "Keyword Exclusion"
                FilterOK = False
                Exit Function
            End If
        Next c
    End If
    
    'Included catchall here pending testing completion
    If bIncluded = True And bExcluded = False And _
        bKeyword = False And bPrefix = False And _
        bBadAttrib = False Then
        FilterOK = True
    Else
        FilterOK = False
        sCause = "Unspecified"
    End If
    
End Function

Function HiddenOrSystem(sFilePath As String) As Boolean
    'Returns true if file has hidden or system attribute set,
    'else false. Called in FilterOK().
    
    Dim bReadOnly As Boolean, bHidden As Boolean, bSystem As Boolean
    Dim bVolume As Boolean, bDirectory As Boolean, a As Long
    
    'check parameter present
    If sFilePath = "" Then
        MsgBox "Empty parameter string in HiddenOrSystem - closing"
        Exit Function
    Else
    End If
    
    'check attributes for hidden or system files
    a = GetAttr(sFilePath)
    If a > 32 Then 'some attributes are set
        'so check the detailed attribute status
        bReadOnly = GetAttr(sFilePath) And 1   'read-only files in addition to files with no attributes.
        bHidden = GetAttr(sFilePath) And 2     'hidden files in addition to files with no attributes.
        bSystem = GetAttr(sFilePath) And 4     'system files in addition to files with no attributes.
        bVolume = GetAttr(sFilePath) And 8     'volume label; if any other attribute is specified, vbVolume is ignored.
        bDirectory = GetAttr(sFilePath) And 16 'directories or folders in addition to files with no attributes.
        
        'check specifically for hidden or system files - read only can be tested in the same way
        If bHidden Or bSystem Then
            'MsgBox "Has a system or hidden marking"
            HiddenOrSystem = True
            Exit Function
        Else
            'MsgBox "Has attributes but not hidden or system"
        End If
    Else
        'MsgBox "Has no attributes set"
    End If
    
End Function

Public Function FileToMD5(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an MD5 hash
    'called by HashString()
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have installed the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath)
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToMD5 = ConvToBase64String(bytes)
    Else
        FileToMD5 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA1(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString()
    'parameter full path with name of file returned in the function as an SHA1 hash
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA1 = ConvToBase64String(bytes)
    Else
        FileToSHA1 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA256(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString()
    'parameter full path with name of file returned in the function as an SHA2-256 hash
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA256Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA256 = ConvToBase64String(bytes)
    Else
        FileToSHA256 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA384(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString()
    'parameter full path with name of file returned in the function as an SHA2-384 hash
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA384Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA384 = ConvToBase64String(bytes)
    Else
        FileToSHA384 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA512(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString() and HashFolder()
    'parameter full path with name of file returned in the function as an SHA2-512 hash
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA512Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA512 = ConvToBase64String(bytes)
    Else
        FileToSHA512 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Private Function GetFileBytes(ByVal sPath As String) As Byte()
    'called by all of the file hashing functions
    'makes byte array from file
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim lngFileNum As Long, bytRtnVal() As Byte
    
    lngFileNum = FreeFile
    
    If LenB(Dir(sPath)) Then ''// Does file exist?
        
        Open sPath For Binary Access Read As lngFileNum
        
        'a zero length file content will give error 9 here
        
        ReDim bytRtnVal(0 To LOF(lngFileNum) - 1&) As Byte
        Get lngFileNum, , bytRtnVal
        Close lngFileNum
    Else
        Err.Raise 53 'File not found
    End If
    
    GetFileBytes = bytRtnVal
    
    Erase bytRtnVal
    
End Function

Function ConvToBase64String(vIn As Variant) As Variant
    'called by all of the file hashing functions
    'used to produce a base-64 output
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim oD As Object
    
    Set oD = CreateObject("MSXML2.DOMDocument")
    With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.base64"
        .DocumentElement.nodeTypedValue = vIn
    End With
    ConvToBase64String = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing
    
End Function

Function ConvToHexString(vIn As Variant) As Variant
    'called by all of the file hashing functions
    'used to produce a hex output
    'Set a reference to mscorlib 4.0 64-bit
    'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim oD As Object
    
    Set oD = CreateObject("MSXML2.DOMDocument")
    
    With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.Hex"
        .DocumentElement.nodeTypedValue = vIn
    End With
    ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing
    
End Function

Function GetFileSize(sFilePath As String) As Double
    'called by CommandButton6_Click() and FilterOK() procedures
    'use this to test for a zero file size
    'takes full path as string in sFileSize
    'returns file size in bytes in nSize
    'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim fs As FileSystemObject, f As File
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FileExists(sFilePath) Then
        Set f = fs.GetFile(sFilePath)
    Else
        GetFileSize = 99999
        Exit Function
    End If
    
    GetFileSize = f.Size
    
End Function

Sub ClearSheetFormats(sht As String)
    'called by CommandButton6_Click() and RunFileListing()
    'clears text only
    'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
    'and not only the '''Net Framework 4.8 Advanced Services'''
    
    Dim WS As Worksheet
    
    Set WS = ThisWorkbook.Worksheets(sht)
    WS.Activate
    
    With WS
        .Activate
        .UsedRange.ClearFormats
        .Cells(1, 1).Select
    End With
    
    Set WS = Nothing

End Sub

Sub ClearSheetContents(sht As String)
    'called by CommandButton6_Click() and RunFileListing()
    'clears text only
    
    Dim WS As Worksheet
    
    Set WS = ThisWorkbook.Worksheets(sht)
    
    With WS
        .Activate
        .UsedRange.ClearContents
        .Cells(1, 1).Select
    End With
    
    Set WS = Nothing

End Sub

Sub FormatColumnsAToB(sSheet As String)
    'called by CommandButton6_Click()
    'formats and autofits the columns A to I
    
    Dim sht As Worksheet
    
    Set sht = ThisWorkbook.Worksheets(sSheet)
    sht.Activate
    'sht.Cells.Interior.Pattern = xlNone
    
    'add headings
    With sht
        .Range("a1").Formula = "Verified?:"
        .Range("b1").Formula = "File Path:"
        
        .Range("A1:B1").Font.Bold = True
        .Range("A2:B20000").Font.Bold = False
        .Range("A2:B20000").Font.Name = "Consolas"
    End With
    
    'autofit columns A to B
    With sht
        .Range("A1").Select
        .Columns("A:I").AutoFit
        .Range("A1").Select
        .Cells.FormatConditions.Delete 'reset any conditional formatting
    End With
    
    Set sht = Nothing

End Sub

Function MakeErrorLog(ByVal sIn As String, Optional sLogFilePath As String = "") As Boolean
    'called by RunFileListing()
    'Appends an error log string block (sIn) for the current hash run onto an error log.
    'If optional file path not given, then uses default ThisWorkbook path and default
    'file name are used.   The default name always has HashErr as its root,
    'with an added date-time stamp. If the proposed file path exists it will be used,
    'else it will be made.  The log can safely be deleted when full.
    'Needs a VBA editor reference to Microsoft Scripting Runtime
    
    Dim fs, f, strDateTime As String, sFN As String
    
    'Make a date-time string
    strDateTime = Format(Now, "dddd, mmm d yyyy") & " - " & Format(Now, "hh:mm:ss AMPM")
    
    'select a default file name
    sFN = "HashErr.txt"
    
    'Create a scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'if path not given then get a default path instead
    If sLogFilePath = "" Then
        sLogFilePath = ThisWorkbook.path & "\" & sFN
    Else
        'some path was provided - so continue
    End If
    
    'Open file for appending text at end(8)and make if needed(1)
    On Error GoTo Err_Handler
    'set second arg to 8 for append, and 1 for read.
    Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
    Err.Clear
    
    'write to file
    f.Write "These " & nErrors & " Files Could Not be Hashed" & _
    vbCrLf & strDateTime & vbCrLf & _
    vbCrLf & sIn & vbCrLf
    
    'close file
    f.Close
    
    MakeErrorLog = True
    Exit Function
    
Err_Handler:
    If Err.Number = 76 Then 'path not found
        
        'make default path for output
        sLogFilePath = ThisWorkbook.path & "\" & sFN
        
        'Open file for appending text at end(8)and make if needed(1)
        Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
        
        'resume writing to file
        Resume Next
    Else:
        If Err.Number <> 0 Then
            MsgBox "Procedure MakeErrorLog has a problem : " & vbCrLf & _
            "Error number : " & Err.Number & vbCrLf & _
            "Error Description : " & Err.Description
        End If
        Exit Function
    End If
    
End Function

Function MakeHashLog(sIn As String, Optional ByVal sName As String = "HashFile") As Boolean
    'called by CommandButton6_Click() and RunFileListing()
    'Makes a one-time log for a hash run string (sIn) to be used for future verification.
    'If optional file path not given, then uses default ThisWorkbook path, and default
    'file name are used.   The default name always has HashFile as its root,
    'with an added date-time stamp. Oridinarily, such a block would be appended,
    'but the unique time stamp in the file name renders it single use.
    'If the file does not exist it will be made. The log can safely be deleted when full.
    'Needs a VBA editor reference to Microsoft Scripting Runtime
    
    Dim fs, f, sFP As String, sDateTime As String
    
    'Make a date-time string
    sDateTime = Format(Now, "ddmmmyy") & "_" & Format(Now, "Hhmmss")
    
    'get path for log, ie path, name, number of entries, date-time stamp, suffix
    sFP = ThisWorkbook.path & "\" & sName & "_" & sDateTime & ".txt"
    
    'set scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'make and open file
    'for appending text (8)
    'make file if not exists (1)
    Set f = fs.OpenTextFile(sFP, 8, 1)
    
    'write record to file
    'needs vbNewLine charas added to sIn
    f.Write sIn '& vbNewLine
    
    'close file
    f.Close
    
    MakeHashLog = True
    
End Function

Function FilePathExists(sFullPath As String) As Boolean
    'called by CommandButton6_Click()
    'Returns true if the file path exists, else false.
    'Add a reference to "Microsoft Scripting Runtime"
    'in the VBA editor (Tools>References).
    
    Dim FSO As Scripting.FileSystemObject
    
    Set FSO = New Scripting.FileSystemObject
    
    If FSO.FileExists(sFullPath) = True Then
        'MsgBox "File path exists"
        FilePathExists = True
    Else
        'msgbox "File path does not exist"
    End If
    
End Function

Function HashString(ByVal sFullPath As String) As String
    'called by HashFolder()
    'Returns the hash string in function name, depending
    'on the userform option buttons. Used for hash run only.
    'Verification runs use a separate dedicated call.
    
    Dim b64 As Boolean
    
    'decide hex or base64 output
    If UserForm1.OptionButton3.Value = True Then
        b64 = False
    Else
        b64 = True
    End If
    
    'decide hash algorithm
    Select Case True
    Case UserForm1.OptionButton5.Value
        HashString = FileToMD5(sFullPath, b64)    'md5
    Case UserForm1.OptionButton6.Value
        HashString = FileToSHA1(sFullPath, b64)   'sha1
    Case UserForm1.OptionButton7.Value
        HashString = FileToSHA256(sFullPath, b64) 'sha256
    Case UserForm1.OptionButton8.Value
        HashString = FileToSHA384(sFullPath, b64) 'sha384
    Case UserForm1.OptionButton9.Value
        HashString = FileToSHA512(sFullPath, b64) 'sha512
    Case Else
    End Select
    
End Function

Function Algorithm() As String
    'called by RunFileListing()
    'Returns the algorithm string based on userform1 options
    'Used only for heading labels of sheet1
    
    Dim b64 As Boolean, sFormat As String
    
    'decide hex or base64 output
    If UserForm1.OptionButton3.Value = True Then
        b64 = False
        sFormat = " - HEX"
    Else
        b64 = True
        sFormat = " - Base64"
    End If
    
    'decide hash algorithm
    Select Case True
    Case UserForm1.OptionButton5.Value
        Algorithm = "MD5 HASH" & sFormat
    Case UserForm1.OptionButton6.Value
        Algorithm = "SHA1 HASH" & sFormat
    Case UserForm1.OptionButton7.Value
        Algorithm = "SHA256 HASH" & sFormat
    Case UserForm1.OptionButton8.Value
        Algorithm = "SHA384 HASH" & sFormat
    Case UserForm1.OptionButton9.Value
        Algorithm = "SHA512 HASH" & sFormat
    Case Else
    End Select
    
End Function

Function SelectFile(sTitle As String) As String
    'called by CommandButton5_Click()
    'opens a file-select dialog and on selection
    'returns its full path string in the function name
    'If Cancel or OK without selection, returns empty string
    
    Dim fd As FileDialog, sPathOnOpen As String
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    sPathOnOpen = "C:\Users\Internet Use\Documents\"
    
    'set the file-types list on the dialog and other properties
    fd.Filters.Clear
    fd.Filters.Add "All Files", "*.*"
    fd.Filters.Add "Excel workbooks", "*.log;*.txt;*.xlsx;*.xlsm;*.xls;*.xltx;*.xltm;*.xlt;*.xml;*.ods"
    fd.Filters.Add "Word documents", "*.log;*.txt;*.docx;*.docm;*.dotx;*.dotm;*.doc;*.dot;*.odt"
    fd.Filters.Add "Executable Files", "*.log;*.txt;*.exe"
        
    fd.AllowMultiSelect = False
    fd.InitialFileName = sPathOnOpen
    fd.Title = sTitle
    fd.InitialView = msoFileDialogViewList 'msoFileDialogViewSmallIcons
    
    'then, after pressing OK...
    If fd.Show = -1 Then ' a file has been chosen
        SelectFile = fd.SelectedItems(1)
    Else
        'no file was chosen - Cancel was selected
        'exit with proc name empty string
        'MsgBox "No file selected..."
        Exit Function
    End If
    
    'MsgBox SelectFile
    
End Function

Function GetAllFileText(sPath As String, sRet As String) As Boolean
    'called by CommandButton6_Click()
    'returns all text file content in sRet
    'makes use of Input method
    
    Dim Number As Integer
    
    'get next file number
    Number = FreeFile
    
    'Open file
    Open sPath For Input As Number
    
    'get entire file content
    sRet = Input(LOF(Number), Number)
    
    'Close File
    Close Number
    
    'transfers
    GetAllFileText = True
    
End Function

Sub NotesHashes()
    'not called
    'There are four main points in regard to GetFileBytes():
    'Does file exist:
    '1... If it does not exist then raises error 53
    ' The path will nearly always exist since it was just read from folders
    'so this problem is minimal unless the use of code is changed to read old sheets
    
    '2...If it exists but for some reason cannot be opened, protected, raises error 53
    'This one is worth dealing with - eg flash drives protect some files...xml
    'simple solution to filter out file type, but other solution unclear...
    'investigate filters for attributes and size?
    
    '3...if the file contents are zero - no text in a text file
    '- error 9 is obtained - subscripts impossible to set for array
    ' this is avoided by missing out a zero size file earlier
    'if there is even a dot in a file windows says it is 1KB
    'if there is only an empty string then it shows 0KB
    
    '4  The redim of the array should specify 0 to LOF etc in case an option base 1 is set
End Sub

See Also[edit | edit source]

External Links[edit | edit source]


Running the FCIV Utility from VBA

Summary[edit | edit source]

The Microsoft FCIV Utility, the File Checksum Integrity Verifier , is a free downloadable zipped package that allows a user to produce both SHA1 and MD5 hashes for any single file, a flat folder, or recursively for all files and folders. It can export its entire results package to a nominated .xml file. It can also conduct verification of file sets against a previously saved listing. It is used from a command prompt, but can be run using the Shell function from code like VBA, or from a batch file. For further reading in its use see: Availability and description of the File Checksum Integrity Verifier utility.

Making File Hash Listings[edit | edit source]

FCIV Hash Run at the Command Line[edit | edit source]

For completion, the command line code here will make an XML file of SHA1 hashes of the entire Documents folder. Omission of the xml term and the path that follows it will result in a screen listing. Notice the need for double quotes for paths that contain spaces.

The fciv utility is assumed here to reside in the FCIV folder.

c:\>FCIV\fciv.exe -r "C:\users\My Folder\Documents" -sha1 -xml "c:\users\My Folder\Documents\myhash.xml"

FCIV Hash Run from VBA[edit | edit source]

The Shell function in VBA has no Wait feature, so the Shell line is best as the last. That is to say, even while the Shell command is still processing, it will pass control to the next line in the procedure that contains it before it is done; so the procedure's end will otherwise interrupt the Shell function and the process is likely to fail. The quotes are also a little different in this case from the usual VBA expectation. Note that all of the paths have been enclosed in two sets of double quotes and that the entire command line itself is then enclosed in one additional set of double quotes. Assuming that the fciv.exe has been downloaded and installed as shown, this code line exports all of the hash strings for every file in the users Documents folder, and all of its subfolders, to the file myhash.xml. An exclusion file path could also have been added.

Notice that the use of VBA has some limitations, in that although an output can be made to a file with great success, verification output is limited to the command line processor. See examples on the page File Checksum Integrity Verifier (FCIV) Examples.

Sub FCIV()
   'runs the fciv function from VBA   
Dim Ret
   Ret = Shell("""c:\FCIV\fciv.exe"" -r ""C:\users\My Folder\Documents"" -sha1 -xml ""c:\users\My Folder\Documents\myhash.xml""")
End Sub

See Also[edit | edit source]

External Links[edit | edit source]


Use Log Files from VBA

Summary[edit | edit source]

At times it is useful to write strings to a text file from VBA. For example, for listing files, their hashes, or for simply logging errors. Text files are here intended to mean files with the .txt suffix. There are several procedures listed in the code module for both writing and reading such files.

Writing to Text Files and Logs[edit | edit source]

  • The procedure SendToLogFile APPENDS a string to a text file. The user optionally selects his own path and file name, but there is no OVERWRITE choice with this method. If user parameters are not given then the defaults are used. This procedure places the parameter string in line with a time date string, with each record entry on a new line.
  • The procedure LogError1 is intended to APPEND log errors, and is an example of the Print# statement. It is assumed here that the log file will always be placed in the same folder as the calling Workbook. As such, no path check is needed, and the minimum of coding applies. All formatting of the parameter text is assumed to be done externally. Readers can find format details for Print# in VBA help, and might also care to compare the advantages of using the Write# statement instead.
  • The procedure LogError2 is also intended to APPEND log errors and performs the same task as LogError1. It is however an example of the OpenTextFile method of the Scripting object. This procedure needs a reference in the VBA editor to Microsoft Scripting Runtime. Notice that this log will write every successive record into the first line unless vbNewLine characters are included at the end of the parameter string itself.
  • Procedure WriteToFile REPLACES any existing text, as opposed to appending it to any existing entries.
  • There are conventions in logging. Logging with a text file (.txt) means placing each record on the same line with the individual fields separated by a single tab character. The number of fields is the same for each record. Another convention is to use a comma-separated file format (.csv) where the fields are separated by commas instead of tabs. Both of these formats can be imported into MS Office applications,though users should pay particular attention as to how different log writing methods handle quotes.

Reading Text Files and Logs[edit | edit source]

  • VBA can also read text files into code for processing. However, once the notion of reading files is introduced, the choice of writing formats becomes more important. In addition, file reading can place more demands on error handling, and testing for path integrity.
  • The procedure GetAllFileText returns the entire contents of a .txt file . Readers should first confirm that the text file exists. File utilities elsewhere in this series would suit this purpose.
  • The procedure GetLineText returns an array of text file lines. The same comments regarding early file checks also apply in this case.

VBA Code[edit | edit source]

Option Explicit

Sub TestSendToLogFile()
    'Run this to test the making of a log entry
    Dim sTest As String
    
    'make a test string
    sTest = "Test String"
    
    'calling procedure - path parameter is optional
    SendToLogFile sTest

End Sub

Function SendToLogFile(ByVal sIn As String, Optional sLogFilePath As String = "") As Boolean
    'APPENDS the parameter string and a date-time string to next line of a log file
    'You cannot overwrite this file; only append or read.
    'If path parameter not given for file, or does not exist, defaults are used.
    'Needs a VBA editor reference to Microsoft Scripting Runtime
        
    Dim fs, f, strDateTime As String, sFN As String
    
    'Make a date-time string
    strDateTime = Format(Now, "dddd, mmm d yyyy") & " - " & Format(Now, "hh:mm:ss AMPM")
    
    'select a default file name
    sFN = "User Log File.txt"
    
    'Create a scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'if path not given then get a default path instead
    If sLogFilePath = "" Then
        sLogFilePath = ThisWorkbook.Path & "\" & sFN
    Else
        'some path was provided - so continue
    End If
    
    'Open file for appending text at end(8)and make if needed(1)
    On Error GoTo ERR_HANDLER
        'set second arg to 8 for append, and 1 for read.
        Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
    Err.Clear
        
    'write to file
    f.Write sIn & vbTab & strDateTime & vbCrLf
    
    'close file
    f.Close

    SendToLogFile = True
    Exit Function

ERR_HANDLER:
    If Err.Number = 76 Then 'path not found
        
        'make default path for output
        sLogFilePath = ThisWorkbook.Path & "\" & sFN
        
        'Open file for appending text at end(8)and make if needed(1)
        Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
        
        'resume writing to file
        Resume Next
    Else:
        If Err.Number <> 0 Then
            MsgBox "Procedure SendToLogFile has a problem : " & vbCrLf & _
            "Error number : " & Err.Number & vbCrLf & _
            "Error Description : " & Err.Description
        End If
        Exit Function
    End If

End Function

Function LogError1(sIn As String) As Boolean
    'APPENDS parameter string to a text file
    'assumes same path as calling Excel workbook
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim sPath As String, Number As Integer
    
    Number = FreeFile 'Get a file number
    sPath = ThisWorkbook.Path & "\error_log1.txt" 'modify path\name here
    
    Open sPath For Append As #Number
    Print #Number, sIn
    Close #Number

    LogError1 = True
    
End Function

Function WriteToFile(sIn As String, sPath As String) As Boolean
    'REPLACES all content of text file with parameter string
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim Number As Integer
    
    Number = FreeFile 'Get a file number
    
    'write string to file
    Open sPath For Output As #Number
    Print #Number, sIn
    Close #Number

    WriteToFile = True
    
End Function

Function LogError2(sIn As String) As Boolean
    'Scripting Method - APPENDS parameter string to a text file
    'Needs VBA editor reference to Microsoft Scripting Runtime
    'assumes same path as calling Excel workbook
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim fs, f, sFP As String
    
    'get path for log
    sFP = ThisWorkbook.Path & "\error_log2.txt"
    
    'set scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'make and open file
    'for appending text (8)
    'make file if not exists (1)
    Set f = fs.OpenTextFile(sFP, 8, 1)
            
    'write record to file
    'needs vbNewLine charas added to sIn
    f.Write sIn '& vbNewLine
        
    'close file
    f.Close

    LogError2 = True
    
End Function

Sub TestGetAllFileText()
    'run this to fetch text file contents
    
    Dim sPath As String, sRet As String, vRet As Variant
    
    sPath = "C:\Users\Your Folder\Documents\test.txt"
    
    'check that file exists - see file utilities page
    'If FileFound(sPath) Then
        If GetAllFileText(sPath, sRet) = True Then
            MsgBox sRet
        End If
    'Else
       'MsgBox "File not found"
    'End If

End Sub

Function GetAllFileText(sPath As String, sRet As String) As Boolean
    'returns all text file content in sRet
    'makes use of Input method
    
    Dim Number As Integer

    'get next file number
    Number = FreeFile

    'Open file
    Open sPath For Input As Number

    'get entire file content
    sRet = Input(LOF(Number), Number)
    
    'Close File
    Close Number

    'transfers
    GetAllFileText = True

End Function

Sub TestGetLineText()
    'run this to fetch text file contents
    
    Dim sPath As String, sRet As String, vRet As Variant
    Dim n As Long
    sPath = "C:\Users\Internet Use\Documents\test.txt"
    
    'check that file exists - see file utilities page
    'If FileFound(sPath) Then
        'print text files lines from array
        If GetLineText(sPath, vRet) = True Then
            For n = LBound(vRet) To UBound(vRet)
                Debug.Print vRet(n)
            Next n
        End If
    'Else
       'MsgBox "File not found"
    'End If

End Sub

Function GetLineText(sPath As String, vR As Variant) As Boolean
    'returns all text file lines in array vR
    'makes use of Input method
    
    Dim Number As Integer, sStr As String
    Dim vW As Variant, sF As String, n As Long
    
    'redim array
    ReDim vW(0 To 1)
    
    'get next file number
    Number = FreeFile

    'Open file
    Open sPath For Input As #Number

    'loop though file lines
    Do While Not EOF(Number)
        n = n + 1
        Line Input #Number, sStr
        ReDim Preserve vW(1 To n)
        vW(n) = sStr
        'Debug.Print sStr
    Loop
    
    'Close File
    Close #Number
    
    'transfers
    vR = vW
    GetLineText = True

End Function


Message Boxes

Summary[edit | edit source]

This code block contains a message box function for YES, NO or CANCEL.

VBA Code[edit | edit source]

Option Explicit
Sub TestYesNoCancel()
    'run to test message box
    
    Dim bDefault As Boolean
    
    If YesNoCancel(bDefault) = True Then
        If bDefault Then
            'do default stuff
            MsgBox "Using default"
        Else
            'do other stuff
            MsgBox "Using other"
        End If
    Else
           'do cancelled stuff
        MsgBox "User cancelled"
        Exit Sub
    End If
End Sub

Function YesNoCancel(bDefault As Boolean) As Boolean
    'Message box for yes, no, or cancel

    Dim Msg As String, Style As Long, Title As String
    Dim Reply As Integer

    'assignments
    Msg = "Do you want the default ?" & vbNewLine & vbNewLine & _
          "Select :" & vbNewLine & _
          "YES ;  for the default," & vbNewLine & _
          "NO ;   for some other," & vbNewLine & _
          "CANCEL ;  to quit."                              'message
    Style = vbYesNoCancel + vbQuestion + vbDefaultButton1   'buttons.
    Title = "Yes, No, Cancel layout..."                     'title.

    'show message box
    Reply = MsgBox(Msg, Style, Title)

    'resolve choice
    Select Case Reply
    Case vbYes
        bDefault = True
        YesNoCancel = True
    Case vbNo
        YesNoCancel = True
        Exit Function
    Case vbCancel
        Exit Function
    End Select

End Function

See Also[edit | edit source]

External Links[edit | edit source]


Input Boxes

Summary[edit | edit source]

This code block contains an input box function. It includes a number of fairly common validation routines that are selected within the main procedure.

VBA Code[edit | edit source]

Option Explicit

Sub TestGetAnInput()
    'run to test input box functions
    
    Dim vR As Variant, bC As Boolean
    
    If GetAnInput(vR, bC) Then
        MsgBox vR
    ElseIf bC = True Then MsgBox "Cancel or too many attempts"
    Else
        MsgBox "Input must be an integer"
    End If
    
End Sub

Function GetAnInput(vRet As Variant, bCancel As Boolean) As Boolean
    '================================================================================
    'Input box function - gets an input from user with choice of validation, or none.
    'Returns value in vRet and funcion True, or bCancel = true and function False.
    'With bUseValidation = True, loops until success, cancel, or 3 failed attempts.
    'With bUseValidation = False, returns first entry without validation.
    'Enable chosen validation function below.
    '================================================================================
    
    Dim Reply As Variant, bValidated As Boolean, n As Long, bUseValidation As Boolean
    Dim sMsg As String, sTitle As String, sDefault As String
    Dim nS As Integer, nE As Integer
        
    'set assignments
    sMsg = "Enter an integer..."
    sTitle = "Input box..."
    sDefault = "1234567890"
    n = 1
    nS = 32: nE = 126 'printing chara set 32-126
    bUseValidation = False 'use validation at all?
    
    Do  'get user input
        Reply = InputBox(sMsg, sTitle, sDefault)
        
        'test if validation needed
        If bUseValidation = False Then
            bValidated = True
            Exit Do
        End If

        'control number of attempts
        If n >= 3 Then 'set attempt limit here
            Exit Do
        End If
        n = n + 1
        
        'add validation by removing comment on one function call
        ' ========================================================
        '            ENABLE ONLY ONE VALIDATION FUNCTION
        ' ========================================================
        ' If IsNumeric(Reply) Then bValidated = True
        ' If IsAnInteger(Reply) Then bValidated = True
        ' If IsADate(Reply) Then bValidated = True
        ' If IsLikeCustomFormat(Reply) Then bValidated = True
        ' If IncludesAscRange(Reply, nS, nE) Then bValidated = True
        ' If ExcludesAscRange(Reply, nS, nE) Then bValidated = True
        ' If IsAllInAscRange(Reply, nS, nE) Then bValidated = True
        '=========================================================
    
    Loop Until bValidated = True Or Reply = ""
    
    'transfers
    If bValidated Then
        vRet = Reply       'got one
        GetAnInput = True
    ElseIf Reply = "" Then 'cancelled
        bCancel = True
    Else                   'too many tries
        bCancel = True
    End If
    
End Function

Function IsAnInteger(ByVal vIn As Variant) As Boolean
    'returns true if input contains an integer

    'check if numeric
    'numeric excludes dates and booleans
    If IsNumeric(vIn) Then
           'check long version against original
           If vIn = CLng(vIn) Then
               IsAnInteger = True
           End If
    End If

End Function

Function IsADate(ByVal vIn As Variant) As Boolean
    'returns true if input contains a date

    'check if date
    If IsDate(vIn) Then
        IsADate = True
    End If

End Function

Function IsAllInAscRange(ByVal vIn As Variant, nS As Integer, _
                                  nE As Integer) As Boolean
    'returns true if entire string lies in asci parameter range
    
    Dim n As Long, sS As String, sAccum As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    '================================================================
    ' Character Set (0-127) ASCI Values            Assignments
    '================================================================
    '48 To 57                                 'integers 0-9
    '65 To 90                                 'capital letters A-Z
    '97 To 122                                'lower case letters a-z
    '33 To 47, 58 To 64,91 To 96, 123 To 126  'printing symbols
    '0 To 7, 11 To 12, 14 To 31, 127          'not Windows supported
    '32                                       'space character
    '8, 9, 10, 13                             'vbBack,vbTab,vbLf,vbCr
    '=================================================================
       
    'accumulate all validated charas
    For n = 1 To Len(vIn)
        sS = Mid(CStr(vIn), n, 1)
        Select Case Asc(sS)
            Case nS To nE 'parameters
                sAccum = sAccum & sS
        End Select
    Next n
     
    If Len(sAccum) = Len(vIn) Then
        IsAllInAscRange = True
    End If

End Function

Function IncludesAscRange(ByVal vIn As Variant, nS As Integer, _
                                  nE As Integer) As Boolean
    'returns true if any part of string lies in asci parameter range
    
    Dim n As Long, sS As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    '================================================================
    ' Character Set (0-127) ASCI Values            Assignments
    '================================================================
    '48 To 57                                 'integers 0-9
    '65 To 90                                 'capital letters A-Z
    '97 To 122                                'lower case letters a-z
    '33 To 47, 58 To 64,91 To 96, 123 To 126  'printing symbols
    '0 To 7, 11 To 12, 14 To 31, 127          'not Windows supported
    '32                                       'space character
    '8, 9, 10, 13                             'vbBack,vbTab,vbLf,vbCr
    '=================================================================
       
    'early exit for first inclusion found
    For n = 1 To Len(vIn)
        sS = Mid(CStr(vIn), n, 1)
        Select Case Asc(sS)
            Case nS To nE 'parameters
                'found - so exit
                IncludesAscRange = True
                Exit Function
        End Select
    Next n
     
End Function

Function ExcludesAscRange(ByVal vIn As Variant, nS As Integer, _
                                  nE As Integer) As Boolean
    'returns true if input does not contain any part of asci parameter range
    
    Dim n As Long, sS As String, sAccum As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    '================================================================
    ' Character Set (0-127) ASCI Values            Assignments
    '================================================================
    '48 To 57                                 'integers 0-9
    '65 To 90                                 'capital letters A-Z
    '97 To 122                                'lower case letters a-z
    '33 To 47, 58 To 64,91 To 96, 123 To 126  'printing symbols
    '0 To 7, 11 To 12, 14 To 31, 127          'not Windows supported
    '32                                       'space character
    '8, 9, 10, 13                             'vbBack,vbTab,vbLf,vbCr
    '=================================================================
       
    'early exit for first inclusion found
    For n = 1 To Len(vIn)
        sS = Mid(CStr(vIn), n, 1)
        Select Case Asc(sS)
            Case nS To nE 'parameters
                'found - so exit
                sAccum = sAccum & sS
        End Select
    Next n
     
    If sAccum = "" Then
        ExcludesAscRange = True
    End If

End Function

Function IsLikeCustomFormat(ByVal vIn As Variant) As Boolean
    'returns true if input pattern is like internal pattern
    
    Dim sPattern As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    'specify the pattern - see help for Like operator
    sPattern = "CAT###-[a-z][a-z]#" 'for example CAT123-fg7
    
    'test the pattern against input
    IsLikeCustomFormat = vIn Like sPattern
     
End Function

See Also[edit | edit source]

External Links[edit | edit source]


Pseudo Random Repeated Substrings

Summary[edit | edit source]

This page describes some matters that apply to the Rnd() function of VBA. In particular it illustrates that repeated substrings can result when the Randomize() function is wrongly positioned inside the same loop as Rnd(), instead of before it.

The VBA Rnd() Function[edit | edit source]

  • The Rnd() function is pseudo random, as opposed to true random . True randomness is found rarely, one notable example being the sequence of data that can be derived from white noise. White noise, like the radio noise from the sun or perhaps the unintentional noise in a radio or other electronic device, has a fairly uniform distribution of frequencies, and can be exploited to produce random distributions of data; also known as linear probability distributions because their frequency distributions are straight lines parallel to the horizontal axis.
  • Pseudo randomness can be obtained with a feedback algorithm, where a sequence of output values of a function is fed back and assists in the making of the next part of an output stream. These are referred to as pseudo random number generators (PRNG). Such a process, although complex, is nonetheless determinate, being based entirely on its starting value. Such generators, depending on their design can produce long sequences of values, all unique, before the entire stream eventually repeats itself.
  • A PRNG output stream will always repeat itself if a long enough set of values is generated. The Rnd function in VBA can generate a sequence of up to 16,777,216 numbers before any one number is repeated, at which time the entire sequence itself is repeated. This is adequate in most cases. The Rnd() function has been described by Microsoft as belonging to the set of PRNGs called Linear Congruential Generators (LCG), though it is unclear as to whether or not the algorithm has since been modified.
  • The Rnd function is not suitable for large tables or for cryptographic use, and VBA itself is quite insecure in its own right. For given starting values the generator always will produce the same sequence. Clearly, if any part of the stream is known, this allows other values in the sequence to be predicted, and this state of affairs is insecure for cryptographic use. Perhaps surprisingly, modeling methods that make much use of random values need even longer unique sequences than that produced by Rnd().
  • The exact coding of the Microsoft Rnd() function is not available, and their descriptive material for it is quite sketchy. A recent attempt by me to implement the assumed algorithm in VBA code failed because of overflow, so those who intend to study such generators in VBA need to use another algorithm. Perhaps study of the Wichmann-Hill (1982) CLCG algorithm, that can be implemented in VBA would be a better choice. A VBA implementation, (by others), of the Wichmann-Hill (1982) algorithm is provided in another page of this series, along with some simpler generator examples.

Worst Case for Rnd() Substrings?[edit | edit source]

  • A well designed PRNG stream consists of unique numbers, but this applies only to the designer's unfiltered set of numbers in the range from zero to unity, [0,1]. As soon as we start to take some values from the stream, and ignore others, say to make custom outputs, the new steams will take on different characteristics. The combination of cherry-picking elements from the natural sequence and the mapping of a large set to a very small set takes its toll. When observing the new set, the count of characters to the cycle repeat point shortens, and the number of repeated substrings increases throughout the set.
  • The code listing below allows checking of a Rnd() stream for substrings, using preset filter settings, eg; capitals, lower case, integers, etc., and in addition, includes a similar generator based on a hash for those who would like to compare it.
  • The repeat substring procedure is quite slow, depending as it does on the location of repeats. The worst case is for no repeats found where the number of cycles becomes maximum at (0.5*n)^2, the square of half the number of characters in the test string. Of course the smallest number of cycles is just one when a simple string is repeated, eg; abcabc. Clearly, an increase of string length by a factor of ten could increase the run time by a factor of one hundred. (1000 characters in about 2 seconds, 2000 in 4secs, 10000 in 200secs, is, so far, the best timing!).
  • Coding layout can affect the length of repeated substrings too. The reader might compare the effect of placing the Randomize function outside the random number loop, then inside the loop, while making an output of only capitals. (See code in MakeLongRndStr). In the past the repeat strings have worsened considerably when placed within. The code as listed here to test Rnd() with 1000 samples of capitals, no use of DoEvents, and Randomize wrongly placed inside the loop, will return a repeat substring of up to four hundred characters for this author. Increasing the code lines in the loop, affecting the time (?) for each iteration of the loop to run, also affects the length of any substrings.
Option Explicit

Sub TestRndForRepeats()
    'run this to make a pseudo random string
    'and to test it for longest repeated substring
    
    Dim strRnd As String, sOut As String
    Dim nOut As Long, nLen As Long
    
    strRnd = MakeLongRndStr(1000)
    MsgBox strRnd,, "Long string..."
    
    sOut = LongestRepeatSubstring(strRnd, nOut)
    
    MsgBox "Repeated substring found is : " & _
       vbCrLf & sOut & vbCrLf & _
       "Number of these found : " & nOut & vbCrLf & _
       "Length of each : " & Len(sOut),, "Repeat substring..."

End Sub

Sub TestHashForRepeats()
    'run this to make a long hash-based output
    'and to test it for longest repeated substring
    
    Dim sOut As String, sHash As String, nOut As Long
    
    sHash = LongHash("String to hash", 1000)
    
    MsgBox "The following sha256-based hash has " & _
           Len(sHash) & " characters." & _
           vbCrLf & vbCrLf & sHash,, "Long hash..."

    sOut = LongestRepeatSubstring(sHash, nOut)
    
    MsgBox "Repeated substring found is : " & _
       vbCrLf & sOut & vbCrLf & _
       "Number of these found : " & nOut & vbCrLf & _
       "Length of each : " & Len(sOut),, "Repeat substring..."

End Sub

Function MakeLongRndStr(nNumChr As Long) As String
    'Makes a long capital letters string using rnd VBA function
    
    Dim n As Long, sChr As String, nAsc As Long
    Dim nSamp As Long, sRec As String
    
    '========================================================================
    ' Notes and Conclusions:
    ' The VBA function rnd is UNSUITED to generation of long random strings.
    ' Both length and number of repeats increases rapidly near 256 charas.
    ' Reasonable results can be obtained by keeping below 128 characters.
    ' For longer strings, consider hash-based methods of generation.
    '========================================================================
    'Randomize 'right place
    Do Until n >= nNumChr
        'DoEvents
        Randomize 'wrong place
        nSamp = Int((122 - 48 + 1) * Rnd + 48) 'range includes all charas
        sChr = Chr(nSamp)
        
        'cherry-picks 10, 26, 36, 52, or 62 from a set of 75
        Select Case nSamp 'chara filter
                Case 65 To 90  'upper case letters
                    sRec = sRec & sChr
                Case 48 To 57  'integers
                    'sRec = sRec & sChr
                Case 97 To 122 'lower case letters
                    'sRec = sRec & sChr
                Case Else
                    'disregard
        End Select
        n = Len(sRec)
    Loop
    
    'MsgBox sAccum
    
    MakeLongRndStr = Left$(sRec, nNumChr)

End Function

Function LongHash(sIn As String, nReq As Long, Optional sSeed As String = "") As String
    'makes a long sha256 hash - length specified by user
    'Parameters: sIn;   the string to hash
                'nReq;  the length of output needed
                'sSeed; optional added string modifier
    
    Dim n As Long, m As Long, c As Long, nAsc As Integer, sChr As String
    Dim sF As String, sHash As String, sRec As String, sAccum As String
    
    Do Until m >= nReq
        DoEvents
        n = n + 1 'increment
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
        'you set your own cycle increment here
        sF = sIn & sSeed & sAccum & (7 * n * m / 3)
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
        'get a single hash of sF
        sHash = HashSHA256(sF)
        'filter output for chara type
        For c = 1 To Len(sHash)
            sChr = Mid$(sHash, c, 1)
            nAsc = Asc(sChr)
            'cherry-picks 10, 26, 36 ,52, or 62 from a set of 64
            Select Case nAsc 'chara filter
                Case 65 To 90  'upper case letters
                    sRec = sRec & sChr
                Case 48 To 57  'integers
                    'sRec = sRec & sChr
                Case 97 To 122 'lower case letters
                    'sRec = sRec & sChr
                Case Else
                    'disregard
            End Select
        Next c
        'accumulate
        sAccum = sAccum & sRec
        m = Len(sAccum)
        sRec = "" 'delete line at your peril!
    Loop
    
    LongHash = Left$(sAccum, nReq)

End Function

Function HashSHA256(sIn As String) As String
    'Set a reference to mscorlib 4.0 64-bit
    'HASHES sIn string using SHA2-256 algorithm
    
    'NOTE
    'total 88 output text charas of base 64
    'Standard empty string input gives : 47DEQpj8HBSa+/...etc,
    
    Dim oT As Object, oSHA256 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA256.ComputeHash_2((TextToHash))
    
    HashSHA256 = ConvB64(bytes)
    
    Set oT = Nothing
    Set oSHA256 = Nothing
   
End Function

Function ConvB64(vIn As Variant) As Variant
    'used to produce a base-64 output
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim oD As Object
    
    Set oD = CreateObject("MSXML2.DOMDocument")
    With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.base64"
        .DocumentElement.nodeTypedValue = vIn
    End With
    ConvB64 = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing
    
End Function

Function LongestRepeatSubstring(sIn As String, Optional nSS As Long) As String
    'finds longest repeated non-overlapping substring (in function name) and number of repeats (in nSS)
    'greatest number cycles = (0.5*n)^2 for when "none found", eg; abcdef (9)
    'shortest number cycles = 1 for one simple duplicated string; eg abcabc
    
    Dim s1 As String, s2 As String, X As Long
    Dim sPrev As String, nPrev As Long, nLPrev As Long
    Dim nL As Long, nTrial As Long, nPos As Long, vAr As Variant
        
    nL = Len(sIn)
    For nTrial = Int(nL / 2) To 1 Step -1
        DoEvents
        For nPos = 1 To (nL - (2 * nTrial) + 1)
            X = 0
            s1 = Mid(sIn, nPos, nTrial)
            s2 = Right(sIn, (nL - nPos - nTrial + 1))
            vAr = Split(s2, s1)
            X = UBound(vAr) - LBound(vAr)
            If X > 0 Then
                If nPrev < X Then
                    sPrev = s1
                    nPrev = X
                End If
            End If
        Next nPos
        If nPrev <> 0 Then
            LongestRepeatSubstring = sPrev
            nSS = nPrev
            Exit Function
        End If
    Next nTrial
End Function



A PRNG for VBA

Summary[edit | edit source]

  • A pseudo-random number generator (PRNG), if run for long enough, generates a characteristic sequence that is based on its algorithm. This sequence repeats forever and is invariant. The Rnd() function of VBA, if placed in a loop without a parameter, and without making use of Randomize() at all, will generate 16,777,216 values between zero and unity, then start again at the beginning, making a repeating sequence with a cycle length of 16,777,216. The only option for the user is to choose the starting point within that one sequence. This is done by choosing a start value or seed. In the case of Rnd(), the start value is chosen in two ways: by default, using the system timer, or with a user-set number. Again, the start parameters that are set by the user do not make new sequences, they just decide which bit of that one long sequence will be used. Linear Congruential Generators (LCG), the type used by Microsoft's Rnd() function are described in detail at Linear congruential generator.
  • The maximum cycle length for a single stage LCG is equal to its modulus. For combined generators, the maximum cycle length is equal to the least common multiple of the cycle lengths of the individual generators. A well-designed generator will have the maximum cycle length and consist only of unique values throughout its sequence, but not all generators are well-designed. The above link describes the design values required to make an LCG with a maximum cycle length over all of its starting values.
  • The code module below contains the Wichmann-Hill (1982) CLCG (combined LCG) in VBA and is fully functional. It is called RndX() and is used in conjunction with its own RandomizeX(). It has a much longer repeat cycle than Microsoft's Rnd(). A summary of the most useful settings for RndX() is given, with additional details for those who need them in a drop box. Sadly, this author lacks the tools and knowledge for any serious testing of number generators, so the offerings below are likely to be of interest only to beginners.
  • Long-cycle generators are awkward to study in Excel. The cycles of both Microsoft's Rnd() and the user function RndX() are much too long to write a complete cycle to a single worksheet column. The solution is either to list only parts of long streams or to make a number generator with a cycle short enough for a full listing. Listing in a single column this way allows confirmation of the repeat cycle length, then after trimming the rows to a complete set, counting rows after the removal of duplicates will confirm for the skeptical that all of the values are unique. A module is included with procedures to list one section of the Wichmann-Hill implementation, that fits into about 30269 rows or so, and another with a very simple generator for further testing, that fits into just 43.

Microsoft's Rnd() algorithm[edit | edit source]

Microsoft's Visual Basic for Applications (VBA), at present uses a linear congruential generator (LCG) for pseudo-random number generation in the Rnd() function. Attempts to implement the Microsoft algorithm in VBA failed owing to overflow. The following is its basic algorithm.

      x1 = ( x0 * a + c ) MOD m
  and;       
      Rnd() = x1/m
  where:
      Rnd() = returned value
      m = modulus = (2^24)
      x1 = new value
      x0 = previous value (initial value 327680)
      a = 16598013
      c = 12820163
      Repeat length = m = (2^24) = 16,777,216

Similarities will be noticed between Microsoft's Rnd() and the one below, described by Wichmann-Hill (1982), in which a sum of three LCG expressions is used in the production of each output number. The combination of expressions gives RndX(), with the coded values, its much improved cycle length of:

      Cycle length = least_common_multiple(30268, 30306, 30322) = 30268 * 30306 * 30322 / 4 = 6,953,607,871,644

VBA Code - Wichmann-Hill (1982)[edit | edit source]

A reminder about module level variables may be in order. Module level variables hold their values between procedure runs. In fact they will retain values until the VBA is no longer used at all or the code is edited. The code has been laced with resets for these variables, to ensure starting with intended values, as opposed to old stored ones from the previous top procedure runs.

On a cautionary note; although this algorithm has improved properties over the resident Rnd(), the applications on which these generators are run are not particularly secure. Consider also that the output of all LCG coding is entirely predictable if the starting value is ever known. In fact, if any part of such a stream is known, then it is possible for those who intend harm to find the entire stream by comparing it with stored values. These facts when taken together limit the use of such a VBA implementation to study or non-critical applications.

That said, these are likely to be the most useful parameter configurations: In each case RandomizeX() should only be called once, before and outside any generator loop that contains RndX(). This advice also applies to the Microsoft function Rnd() and its companion Randomize().

  • To produce outputs with an unpredictable start point, and a different start point each time it is run:
    • Call RandomizeX without any parameter before calling RndX, also without any parameter. This uses the system timer.
  • To produce outputs from a large set of start points, repeatable, and chosen by a user parameter:
    • Call RandomizeX with any numeric parameter before calling RndX without any parameter. Changed RandomizeX parameter values result in different start points of the standard algorithm stream.
  • To produce an unpredictable, single value, different each time it is run:
    • Call RandomizeX without any parameter before calling RndX with a parameter of zero. This uses the system timer.
  • To produce a repeatable single value, related to, and chosen by a user parameter:
    • Call RandomizeX with any numeric parameter before calling RndX with a parameter of zero. Changed RandomizeX parameter values result in different values that are peculiar to each parameter.
  • Refer to the drop box below for a complete tabulation of the parameter settings and their outcomes.
PRNG RndX() and RandomizeX() Parameter Details
RndX() and RandomizeX() Parameter Details
RandomizeX()
parameter
RndX()
parameter
Behaviour of function
(assuming coding is to produce a sequence)
none. none PRNG stream determined by runtime sampling of the computer’s system timer. Stream uncertain.
none positive PRNG stream determined by runtime sampling of the computer’s system timer. Stream uncertain. Positive parameters of RndX() do not affect it at all.
none negative One number, repeatable, and each one different and depending on the value of RndX() parameter.
Example; RndX(-3) leads to 0.05079271
none zero One number, repeatable, decided by runtime sampling of the computer’s system timer;
Example; sequence is 0.1741…, 01741…
numeric2 none PRNG stream, repeatable, and each one different and depending on the value of RandomizeX() parameter.
numeric positive PRNG stream, repeatable, and each one different and depending on the value of RandomizeX() parameter. Positive parameters of RndX() do not affect it at all.
numeric negative One number, repeatable, and each one different and depending on the value of RndX() parameter. The RandomizeX() parameter value has no effect at all.
Example; RndX(-51) leads to 0.8634…
numeric zero One number, repeatable, and each one different and depending on the value of RandomizeX() parameter.
Example; RandomizeX(2346) leads to 0.2322…
function
not used
none Default PRNG stream, repeatable, and always same.
Example; sequence is 0.8952…, 0.1114…, 0.9395…
function
not used
positive Default PRNG stream, repeatable, and always same.
Example; sequence is 0.8952…, 0.1114…, 0.9395…
function
not used1
negative
or zero
One number, repeatable, and each one different and depending on the value of RndX() parameter.
Example; RndX(0) = 0.8694...: -5 = 0.0846…


1. The term Function not used is intended to mean that the function is not specifically called in code by the user. In some cases, for example this one, the RandomizeX() function still needs to be available in code for the RndX() function's internal call.
2. Numeric items are those that can be made into a number. The RandomizeX() function produces a positive integer using the seed value given in its variant parameter. It does this for any leading part of a string also, right up to the first character that cannot be recognized as numeric.



The code in this section should be saved as a separate standard module in Excel.

Option Explicit
Dim nSamples As Long
Dim nX As Long, nY As Long, nZ As Long

Sub TestRndX()
    'run this to obtain RndX() samples
    'Wichmann, Brian; Hill, David (1982), Algorithm AS183:
    'An Efficient and Portable Pseudo-Random Number Generator,
    'Journal of the Royal Statistical Society. Series C
    Dim n As Long
   
    'reset module variables
    nX = 0: nY = 0: nZ = 0
    
    RandomizeX
    For n = 1 To 10
        Debug.Print RndX()
        MsgBox RndX()
    Next n
   
    'reset module variables
    nX = 0: nY = 0: nZ = 0

End Sub

Sub TestScatterChartOfPRNG()
    'run this to make a point scatter chart
    'using samples from RndX
    
    Dim vA As Variant, n As Long
    Dim nS As Long, nR As Double
    
    'remove any other charts
    'DeleteAllCharts
    
    'reset module variables
    nX = 0: nY = 0: nZ = 0
    
    'set number of samples here
    nSamples = 1000
    ReDim vA(1 To 2, 1 To nSamples) 'dimension array
        
    'load array with PRNG samples
    RandomizeX
    For n = 1 To nSamples
        nR = RndX()
        vA(1, n) = n  'x axis data - sample numbers
        vA(2, n) = nR 'y axis data - prng values
    Next n
    
    'make scatter point chart from array
    ChartScatterPoints vA, 1, 2, nSamples & " Samples of RndX()", _
                "Sample Numbers", "PRNG Values [0,1]"
    
    'reset module work variables
    nX = 0: nY = 0: nZ = 0

End Sub

Sub RandomizeX(Optional ByVal nSeed As Variant)
   'sets variables for PRNG procedure RndX()
      
   Const MaxLong As Double = 2 ^ 31 - 1
   Dim nS As Long
   Dim nN As Double
   
   'make multiplier
   If IsMissing(nSeed) Then
      nS = Timer * 60
   Else
      nN = Abs(Int(Val(nSeed)))
      If nN > MaxLong Then 'no overflow
         nN = nN - Int(nN / MaxLong) * MaxLong
      End If
      nS = nN
   End If
   
   'update variables
   nX = (nS Mod 30269)
   nY = (nS Mod 30307)
   nZ = (nS Mod 30323)
   
   'avoid zero state
   If nX = 0 Then nX = 171
   If nY = 0 Then nY = 172
   If nZ = 0 Then nZ = 170

End Sub

Function RndX(Optional ByVal nSeed As Long = 1) As Double
   'PRNG - gets pseudo random number - use with RandomizeX
   'Wichmann-Hill algorithm of 1982
   
   Dim nResult As Double
   
   'initialize variables
   If nX = 0 Then
      nX = 171
      nY = 172
      nZ = 170
   End If
   
   'first update variables
   If nSeed <> 0 Then
      If nSeed < 0 Then RandomizeX (nSeed)
      nX = (171 * nX) Mod 30269
      nY = (172 * nY) Mod 30307
      nZ = (170 * nZ) Mod 30323
   End If
   
   'use variables to calculate output
   nResult = nX / 30269# + nY / 30307# + nZ / 30323#
   RndX = nResult - Int(nResult)

End Function

Sub ChartScatterPoints(ByVal vA As Variant, RowX As Long, RowY As Long, _
                     Optional sTitle As String = "", Optional sXAxis As String, _
                     Optional sYAxis As String)
    
    'array input must contain two data rows for x and y data
    'parameters for user title, x axis and y axis labels
    'makes a simple point scatter chart
    
    Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long, n As Long, bOptLim As Boolean
    Dim X As Variant, Y As Variant, sX As String, sY As String, sT As String, oC As Chart
    
    LBR = LBound(vA, 1): UBR = UBound(vA, 1)
    LBC = LBound(vA, 2): UBC = UBound(vA, 2)
    ReDim X(LBC To UBC)
    ReDim Y(LBC To UBC)
    
    'labels for specific charts
    If sTitle = "" Then sT = "Title Goes Here" Else sT = sTitle
    If sXAxis = "" Then sX = "X Axis Label Goes Here" Else sX = sXAxis
    If sYAxis = "" Then sY = "Y Axis Label Goes Here" Else sY = sYAxis
    
    If RowX < LBR Or RowX > UBR Or RowY < LBC Or RowY > UBC Then
        MsgBox "Parameter data rows out of range in ChartColumns - closing"
        Exit Sub
    End If
    
    'transfer data to chart arrays
    For n = LBC To UBC
        X(n) = vA(RowX, n) 'x axis data
        Y(n) = vA(RowY, n) 'y axis data
    Next n
    
    'make chart
    Charts.Add
    
    'set chart type
    ActiveChart.ChartType = xlXYScatter 'point scatter chart
        
    'remove unwanted series
    With ActiveChart
        Do Until .SeriesCollection.Count = 0
            .SeriesCollection(1).Delete
        Loop
    End With
    
    
    'assign the data and labels to a series
    With ActiveChart.SeriesCollection
        If .Count = 0 Then .NewSeries
            If Val(Application.Version) >= 12 Then
                .Item(1).Values = Y
                .Item(1).XValues = X
            Else
                .Item(1).Select
                Names.Add "_", X
                ExecuteExcel4Macro "series.x(!_)"
                Names.Add "_", Y
                ExecuteExcel4Macro "series.y(,!_)"
                Names("_").Delete
            End If
    End With
        
    'apply title string, x and y axis strings, and delete legend
    With ActiveChart
        .HasTitle = True
        .ChartTitle.Text = sT
        .SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
        .Axes(xlCategory).AxisTitle.Text = sX
        .SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
        .Axes(xlValue).AxisTitle.Text = sY
        .Legend.Delete
    End With
    
    'trim axes to suit
    With ActiveChart
    'X Axis
        .Axes(xlCategory).Select
        .Axes(xlCategory).MinimumScale = 0
        .Axes(xlCategory).MaximumScale = nSamples
        .Axes(xlCategory).MajorUnit = 500
        .Axes(xlCategory).MinorUnit = 100
        Selection.TickLabelPosition = xlLow
        
    'Y Axis
        .Axes(xlValue).Select
        .Axes(xlValue).MinimumScale = -0.2
        .Axes(xlValue).MaximumScale = 1.2
        .Axes(xlValue).MajorUnit = 0.1
        .Axes(xlValue).MinorUnit = 0.05
    End With
    
    
    ActiveChart.ChartArea.Select
    
    Set oC = Nothing

End Sub

Sub DeleteAllCharts5()
    'run this to delete all ThisWorkbook charts
    
    Dim oC
       
    Application.DisplayAlerts = False
    
    For Each oC In ThisWorkbook.Charts
        oC.Delete
    Next oC
    
    Application.DisplayAlerts = True
    
End Sub

Simpler Tests of PRNGs[edit | edit source]

The code module below contains a stripped down version of the Wichmann-Hill (1982) algorithm, in fact using only the first of its three calculated sections. It will make several complete streams of values on Sheet1 of the workbook in which it is run, using different start values. Notice that the first values are all repeated at row 30269, as will the whole stream if extended. After producing the list, use the spreadsheet's functions for column sorting and the removal of duplicates to see that each column contains the appropriate number of unique entries. An even simpler generator with a repeat cycle of just 43 is also included that might make study more manageable, and the cycle of Microsoft's Rnd() can be seen to repeat at 16777216 (+1) by running TestMSRnd.

The code in this section should be saved as a separate standard module in Excel.

Option Explicit

Private ix2 As Long

Sub TestWHRnd30269()
    'makes five columns for complete output streams
    'each with a different start point
    'runs a simplified LCNG with mod 30269
        
    Dim sht As Worksheet, nS As Double, nSamp As Long
    Dim c As Long, r As Long, nSeed As Long
    
    'set seed value for Rnd2()
    nSeed = 327680 'WH initial seed
    
    'set number of random samples to make
    nSamp = 30275 '30269 plus say, 6
    
    'set initial value of carry variable
    ix2 = nSeed
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    
    'clear the worksheet
    sht.Cells.Cells.ClearContents
    
    'load sheet with set of samples
    For c = 1 To 5                'number of runs
        ix2 = nSeed + c           'change start value
        For r = 1 To nSamp        'number of samples
            nS = WHRnd30269()     'get a sample
            sht.Cells(r, c) = nS  'write to sheet
        Next r
    Next c

    sht.Cells(1, 1).Select

End Sub

Function WHRnd30269() As Double
   'first part of Wichmann-Hill tripple.
   'When started with seed ix2 = 171,
   'full sequence repeats from n = 30269
   'without any repeated values before.
   
   Dim r As Double
   
   'ix2 cannot be 0.
   If ix2 = 0 Then
      ix2 = 171
   End If
   
   'calculate Xn+1 from Xn
   ix2 = (171 * ix2) Mod 30269
   
   'make an output value
   r = ix2 / 30269#
   WHRnd30269 = r - Int(r)

End Function

Sub TestSimpleRnd43()
    'makes five columns for complete output streams
    'each with a different start point
    'runs a very simple LCNG with mod 43
        
    Dim sht As Worksheet, nS As Double, nSamp As Long
    Dim c As Long, r As Long, nSeed As Long
    
    'set seed value for Rnd2()
    nSeed = 17 'initial seed
    
    'set number of random samples to make
    nSamp = 45 '43 plus say, 2
    
    'set initial value of carry variable
    ix2 = nSeed
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    
    'clear the worksheet
    sht.Cells.Cells.ClearContents
    
    'load sheet with set of samples
    For c = 1 To 5                'number of runs
        ix2 = nSeed + c           'change start value
        For r = 1 To nSamp        'number of samples
            nS = SimpleRnd43()    'get a sample
            sht.Cells(r, c) = nS  'write to sheet
        Next r
    Next c

    sht.Cells(1, 1).Select

End Sub

Function SimpleRnd43() As Double
   'simple Lehmer style LCNG to show repeat streams
   'produces one sequence of 42 unique values - then repeats entire sequence
   'start value decides only where the predictable sequence begins
   
   Dim r As Double
   
   'Note; Makes 42 unique values before sequence repeats
   'Modulus = 43: Multiplier = 5: Initial Seed = 17
   '43 is prime
   '5 is primitive root mod 43
   '17 is coprime to 43
   
   'ix2 cannot be 0.
   If ix2 = 0 Then
      ix2 = 17
   End If
   
   'calculate a new carry variable
   ix2 = (5 * ix2) Mod 43
   
   'make an output value
   r = ix2 / 43#
   SimpleRnd43 = r - Int(r)

End Function

Sub TestMSRnd()
    'makes two sets of single data using MS Rnd
    'the first 10 samples of Rnd() values
    'followed by values around sample 16777216
    'confirms sequence probably re-starts at M+1 = 16777217
    
    Dim sht As Worksheet, nS As Double
    Dim c As Long, r As Long, nMod As Long
    
    'note modulus
    nMod = 16777216
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    
    'clear the worksheet
    sht.Cells.Cells.ClearContents
    
    'load sheet with set of samples
    
        For r = 1 To nMod + 20   'number of samples
            nS = Rnd()            'get a sample
            Select Case r
                Case 1 To 10
                    sht.Cells(r, 1) = r
                    sht.Cells(r, 2) = nS
                Case (nMod - 4) To (nMod + 5)
                    sht.Cells(r - 16777211 + 10, 1) = r
                    sht.Cells(r - 16777211 + 10, 2) = nS
            End Select
        Next r
    
    sht.Cells(1, 1).Select

End Sub

References[edit | edit source]

  • Wichmann, Brian; Hill, David (1982), Algorithm AS183: An Efficient and Portable Pseudo-Random Number Generator, Journal of the Royal Statistical Society. Series C

See Also[edit | edit source]

External Links[edit | edit source]


A Pseudo Random Character Table

Summary[edit | edit source]

This code module is intended for MS Excel. It makes a pseudo random table of characters, integers and capitals in this case, on Sheet1. A new and different table is made each time the procedure is run.

The Table[edit | edit source]

  • Copy the code into a standard VBA module in Excel, and run the procedure MakePseudoRandomTable() to make a table. As shown, Sheet1 will be overwritten.
  • The output uses a monospaced font, Consolas, for the clearest layout and type. In addition to ensuring a neat layout vertically and horizontally, monospaced tables allow the reading of sequences on a diagonal, so greatly extend their usefulness.
  • Adjust the size of the table by changing the values nRows, and nCols in the code heading, and if necessary insert the name of the sheet to use. The code will add numbered row and column headings and will add these to each page that is displayed or printed.
  • If an exact number of columns and rows is needed, adjust the margins for the sheet, and perhaps the font size until the required result is obtained.
  • The proportion of integers to capitals is just 10/36, but is easily changed in code with a little effort.

The VBA Code Module[edit | edit source]

Option Explicit

Sub MakePseudoRandomTable()
    ' Makes a pseudo random table of integers and capitals
    ' using VBA internal function Rnd().
    
    'NOTES
    ' User should set narrow margins for best use of page.
    ' This will give about 47 rows by 35 cols
    ' Numbered headings are set to repeat on each printed page.
    ' Set number of rows and columns below.
    ' Integers to capitals ratio approx 10:26 = 0.385.
    ' Enter "0-127" in VBA Help for link to ASCI code numbers.
    
    Dim sht As Worksheet, sStr As String
    Dim nX As Integer, nAsc As Integer
    Dim nRows As Long, nCols As Long
    Dim nR As Long, nC As Long
       
    'set required table size and worksheet name here
    nRows = 100 'number of rows
    nCols = 100 'number of columns
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    sht.Activate
    
    'clear and format worksheet
    With sht.Columns
        .ClearContents
        .ClearFormats
        .HorizontalAlignment = xlCenter
        .Font.Name = "Consolas" 'monospaced
        .Font.Size = 12
        .ColumnWidth = 2
    End With
    
    Randomize Timer 'seed system timer
    For nR = 1 To nRows     'row loop
        For nC = 1 To nCols 'col loop
            'allow break commands
            DoEvents
            'choose integer between 1 and 36 (total number of characters)
            nX = Int((36 - 1 + 1) * Rnd + 1)
            'make asci numbers in a decided proportion
            'set nX<=18 And nX>=1 here for equal integers and capitals
            If nX <= 10 And nX >= 1 Then 'for 10:26
                nAsc = Int((57 - 48 + 1) * Rnd + 48) 'integers 48 to 57
            Else
                nAsc = Int((90 - 65 + 1) * Rnd + 65) 'capitals 65 to 90
            End If
            'convert asci number to string
            sStr = Chr(nAsc)
            'print single string character per cell
            sht.Cells(nR, nC).Value = sStr
        Next nC
    Next nR
        
    'add numbers to column headings
    For nC = 1 To nCols
        sht.Cells(1, nC) = nC
    Next nC
    'set size and orientation of column headings
    With sht.Rows(1)
        .Font.Size = 12
        .Orientation = 90 'vertical
    End With
    
    'add numbers to row headings
    For nR = 1 To nRows
        sht.Cells(nR, 1) = nR
    Next nR
    'set size of row headings
    With sht.Columns(1)
        .Font.Size = 12
    End With
    
    
    'print row and col headings on every page
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = "$A:$A"
    End With
    Application.PrintCommunication = True
    
    'select first cell
    sht.Cells(1, 1).Select

End Sub

See Also[edit | edit source]

External Links[edit | edit source]


Listing Prime Numbers

Summary[edit | edit source]

Figure 1:The Sieve of Eratosthenes. It is a methodical procedure for finding prime numbers, originally using a table. Notice that factors are eliminated only up to and including that which exceeds the square root of 120 (= 11). (Graphic by SKopp at German Wikipedia

.

This module implements the Sieve of Eratosthenes method for the listing of prime numbers. It is made to run in Microsoft Excel as a standard VBA module. It lists the prime numbers found between unity and some parameter integer value, on Sheet1 of the Workbook, and makes use of a message box for short listings.

  • Overflow is a problem for such procedures, but provided that the input parameter is kept within a few millions or so, overflow is unlikely.
  • The method although simple is quite slow, since even to test one single value, the entire sequence of multiples (2,3,5,7,...n) must be completed. Large values of input will take several minutes to complete. A faster approach is to test only those factors that are smaller than the square root of the input value; this modification is used in the procedure GetPrimeFactors().
  • Note that the procedure will clear any contents of Sheet1 before each listing.
  • An animated GIF found in Wiki Commons is included in Figure 1 to illustrate the method.
  • GetPrimeFactors() and its utility DecMod() list the prime factors of a supplied integer. It is written for the decimal subtype, and so it handles inputs of up to 28 full digits, (assuming all nines). The time to complete varies greatly, depending on how many primes are found. There is one peculiarity noted; for example, with an input of 23 nines the answer takes a very long time, but for 28 nines it takes just fifteen seconds or so. Other values like 20, 21, and 22 nines, and so on, are virtually instantaneous. The use of a string for input in the test procedure testGetPrimeFactors() is simply to prevent Excel from truncating the displayed input integer, and has no bearing on the method used; it is not string math here; just a decimal subtype loop.

Code Notes[edit | edit source]

The Code Module[edit | edit source]

Option Explicit

Sub testListPrimes()
    'Run this to list primes in range of
    'unity to some integer value
        
    Dim nNum As Long
    
    'set upper limit of range here
    'eg:1234567 gives 95360 primes from 2 to 1234547 in 3 minutes
    nNum = 1234567  
        
    'MsgBox ListPrimes(nNum)
    
    ListPrimes nNum

End Sub

Function ListPrimes(nInput As Long) As String
    'Lists primes in range unity to nInput
    'Output to Sheet1 and function name
    'Method: Sieve of Eratosthenes

    Dim arr() As Long, oSht As Worksheet, sOut As String
    Dim a As Long, b As Long, c As Long, s As Long
    Dim nRow As Long, nCol As Long
    
    'dimension array
    ReDim arr(1 To nInput)
    
    'set reference to Sheet1
    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    With oSht
        .Activate
        .Cells.ClearContents
    End With
    
    'fill work array with integers
    If nInput > 1 Then
        arr(1) = 0 'exception first element
        For a = 2 To nInput
           arr(a) = a
        Next a
    Else
        MsgBox "Needs parameter greater than unity - closing"
        Exit Function
    End If
    
    'Sieve of Eratosthenes
    'progressively eliminate prime multiples
    For b = 2 To nInput
        DoEvents 'yield
        If arr(b) <> 0 Then 'skip zeroed items
            'replace prime multiples with zero
            s = 2 * b
            Do Until s > nInput
                DoEvents 'yield
                arr(s) = 0
                s = s + b
            Loop
        End If
    Next b
    
    'Output of primes
    sOut = "Primes in range 1 to " & nInput & ":" & vbCrLf
    nRow = 1: nCol = 1
    For c = 2 To nInput
        If arr(c) <> 0 Then
            oSht.Cells(nRow, nCol) = c 'primes list to Sheet1
            nRow = nRow + 1
            If c <> nInput Then        'and accumulate a string
                sOut = sOut & c & ","
            Else
                sOut = sOut & c
            End If
        End If
    Next c
            
    ListPrimes = sOut

End Function

Sub testGetPrimeFactors()
    'Run this for prime factors of integer
    'Set integer as a string in sIn to avoid display truncation
    'Decimal subtype applies and limited to 28 full digits.
    
    Dim nIn, sIn As String, Reply, sOut As String, sT As String
    
    'set integer to factorise here, as a string
    sIn = "9999999999999999999999999999"  '28 nines takes 15 seconds
    nIn = CDec(sIn)
    
    sOut = GetPrimeFactors(nIn)

    MsgBox sOut & vbCrLf & _
           "Input digits length : " & Len(sIn)
           
    'optional inputbox allows copy of output
    Reply = InputBox("Factors of" & nIn, , sOut)

End Sub

Function DecMod(Dividend As Variant, Divisor As Variant) As Variant
    ' Declare two double precision variables
    
    Dim D1 As Variant, D2 As Variant

    D1 = CDec(Dividend)
    D2 = CDec(Divisor)
            
    'return remainder after division
    DecMod = D1 - (Int(D1 / D2) * D2)

End Function

Function GetPrimeFactors(ByVal nN As Variant) As String
    'Returns prime factors of nN in parameter
    'Maximum of 28 digits full digits for decimal subtype input.
    'Completion times vary greatly - faster for more primes
    '20,21,and 22 nines factorise immediately, 23 nines time excessive.
    '25 nines in 6 seconds. Maximum input takes 15 seconds for 28 nines.
    
    Dim nP As Variant, sAcc As String

    nP = CDec(nP)
    nP = 2
    nN = CDec(nN)
    sAcc = nN & " = "
    
    'test successive factors
    Do While nN >= nP * nP
       DoEvents
       If DecMod(nN, nP) = 0 Then
          sAcc = sAcc & nP & " * "
          nN = nN / nP '(divide by prime)
       Else
          nP = nP + 1
       End If
    Loop
    
    'output results
    GetPrimeFactors = sAcc & CStr(nN)
    
End Function

See Also[edit | edit source]


Big Number Arithmetic with Strings

Summary[edit | edit source]

  • This VBA module is intended for Microsoft Excel but can run with minor changes in any of the MS Office applications with a VBA editor.
  • The data types of VBA prevent big number calculations. That is to say, beyond twenty or thirty digits, and even then much care is needed to avoid overflow. Strings have few such restrictions, being limited in most cases to the size of the memory space of the application.
  • The code module below includes most of the basic arithmetic functions without any size restriction.
  • The work is not by this author, but credit should be given to Rebecca Gabriella's String Math Module notes at Big Integer Library. This author has made only cosmetic changes to the work, and added a test procedure to illustrate its use.

Code Notes[edit | edit source]

  • The module includes functions for the following: Addition, subtraction, multiplication, and division, all using integer strings. Also included are conversion functions to restore base10 from some other base, and to produce a new base from some existing base10 input. Other support functions such as RealMod() are also included.
  • No output code to the sheet has been provided. Owing to Excel's habit of truncating numbers, even if they are strings, users who want to use the worksheet should concatenate an apostrophe before the display string to prevent this happening. The apostrophe will not be displayed. It is unclear how else this device affects the subsequent use of the numbers.
  • A remainder after division is produced. It can be found as sLastRemainder, and is public.
  • Users who install code in MS Access should change the Option Compare Text to Option Compare DataBase. The former is intended for MS Excel.

The VBA String Math Module[edit | edit source]

Option Explicit
Option Compare Text 'Database for Access
'--------------------------------------------------------------------------------------------------------------
'https://cosxoverx.livejournal.com/47220.html
'Credit to Rebecca Gabriella's String Math Module (Big Integer Library) for VBA (Visual Basic for Applications)
' Minor edits made with comments and other.
'--------------------------------------------------------------------------------------------------------------

Public Type PartialDivideInfo
    Quotient As Integer
    Subtrahend As String
    Remainder As String
End Type

Public sLastRemainder As String
Private Const Alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Private Sub TestMultAndDiv()
    'Run this to test multiplication and division with integer strings
    'Open immediate window in View or with ctrl-g to see results
    
    Dim sP1 As String, sP2 As String, sRes1 As String, sRes2 As String
    
    sP1 = "6864797660130609714981900799081393217269" & _
          "4353001433054093944634591855431833976560" & _
          "5212255964066145455497729631139148085803" & _
          "7121987999716643812574028291115057151"         '157 digits and prime
    sP2 = "162259276829213363391578010288127"             '33 digits and also prime

    'multiply these two as integer strings
    sRes1 = Multiply(sP1, sP2)
    Debug.Print sP1
    Debug.Print "Length of 1st number : " & Len(sP1)
    Debug.Print sP2
    Debug.Print "Length of 2nd number : " & Len(sP2)
    Debug.Print "Product : " & sRes1
    Debug.Print "Length of product : " & Len(sRes1)
    Debug.Print " "

    'then divide the product by sP1 obtains sP2 again
    sRes2 = Divide(sRes1, sP1)
    Debug.Print sRes1
    Debug.Print "Length of 1st number : " & Len(sRes1)
    Debug.Print sP1
    Debug.Print "Length of 2nd number : " & Len(sP1)
    Debug.Print "Integer Quotient : " & sRes2
    Debug.Print "Length of quotient : " & Len(sRes2)
    Debug.Print "Remainder after integer division : " & sLastRemainder
    Debug.Print " "

    'Notes:
    'Clear immediate window with ctrl-g, then ctrl-a, then delete
    'If sending long integer strings to the worksheet, prefix with apostrophe before output
    'or it will be truncated by Excel.  Needs consideration also on pickup from sheet.
    'Alternatively use a textbox in a userform for error free display.  Ctrl-C to copy out.

End Sub

Private Function Compare(ByVal sA As String, ByVal sB As String) As Integer
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns an integer that represents one of three states
    'sA > sB returns 1, sA < sB returns -1, and sA = sB returns 0
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
    Dim i As Integer, iA As Integer, iB As Integer
    
    'handle any early exits on basis of signs
    bAN = (Left(sA, 1) = "-")
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2)
    If bBN Then sB = Mid(sB, 2)
    If bAN And bBN Then
        bRN = True
    ElseIf bBN Then
        Compare = 1
        Exit Function
    ElseIf bAN Then
        Compare = -1
        Exit Function
    Else
        bRN = False
    End If
    
    'remove any leading zeros
    Do While Len(sA) > 1 And Left(sA, 1) = "0"
        sA = Mid(sA, 2) 'starting at pos 2
    Loop
    Do While Len(sB) > 1 And Left(sB, 1) = "0"
        sB = Mid(sB, 2) 'starting at pos 2
    Loop
    
    'then decide size first on basis of length
    If Len(sA) < Len(sB) Then
        Compare = -1
    ElseIf Len(sA) > Len(sB) Then
        Compare = 1
    Else 'unless they are the same length
        Compare = 0
        'then check each digit by digit
        For i = 1 To Len(sA)
            iA = CInt(Mid(sA, i, 1))
            iB = CInt(Mid(sB, i, 1))
            If iA < iB Then
                Compare = -1
                Exit For
            ElseIf iA > iB Then
                Compare = 1
                Exit For
            Else 'defaults zero
            End If
        Next i
    End If
    
    'decide about any negative signs
    If bRN Then
        Compare = -Compare
    End If

End Function

Public Function Add(ByVal sA As String, ByVal sB As String) As String
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns sum of sA and sB as string integer in Add()
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
    Dim iA As Integer, iB As Integer, iCarry As Integer
       
    'test for empty parameters
    If Len(sA) = 0 Or Len(sB) = 0 Then
        MsgBox "Empty parameter in Add()"
        Exit Function
    End If
        
    'handle some negative values with Subtract()
    bAN = (Left(sA, 1) = "-")
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2)
    If bBN Then sB = Mid(sB, 2)
    If bAN And bBN Then 'both negative
        bRN = True      'set output reminder
    ElseIf bBN Then     'use subtraction
        Add = Subtract(sA, sB)
        Exit Function
    ElseIf bAN Then     'use subtraction
        Add = Subtract(sB, sA)
        Exit Function
    Else
        bRN = False
    End If
    
    'add column by column
    iA = Len(sA)
    iB = Len(sB)
    iCarry = 0
    Add = ""
    Do While iA > 0 And iB > 0
        iCarry = iCarry + CInt(Mid(sA, iA, 1)) + CInt(Mid(sB, iB, 1))
        Add = CStr(iCarry Mod 10) + Add
        iCarry = iCarry \ 10
        iA = iA - 1
        iB = iB - 1
    Loop
    
    'Assuming param sA is longer
    Do While iA > 0
        iCarry = iCarry + CInt(Mid(sA, iA, 1))
        Add = CStr(iCarry Mod 10) + Add
        iCarry = iCarry \ 10
        iA = iA - 1
    Loop
    'Assuming param sB is longer
    Do While iB > 0
        iCarry = iCarry + CInt(Mid(sB, iB, 1))
        Add = CStr(iCarry Mod 10) + Add
        iCarry = iCarry \ 10
        iB = iB - 1
    Loop
    Add = CStr(iCarry) + Add
    
    'remove any leading zeros
    Do While Len(Add) > 1 And Left(Add, 1) = "0"
        Add = Mid(Add, 2)
    Loop
    
    'decide about any negative signs
    If Add <> "0" And bRN Then
        Add = "-" + Add
    End If

End Function

Private Function RealMod(ByVal iA As Integer, ByVal iB As Integer) As Integer
    'Returns iA mod iB in RealMod() as an integer. Good for small values.
    'Normally Mod takes on the sign of iA but here
    'negative values are increased by iB until result is positive.
    'Credit to Rebecca Gabriella's String Math Module with added edits.
    'https://cosxoverx.livejournal.com/47220.html
        
    If iB = 0 Then
        MsgBox "Divide by zero in RealMod()"
        Exit Function
    End If
    
    If iA Mod iB = 0 Then
        RealMod = 0
    ElseIf iA < 0 Then
        RealMod = iB + iA Mod iB 'increase till pos
    Else
        RealMod = iA Mod iB
    End If

End Function

Private Function RealDiv(ByVal iA As Integer, ByVal iB As Integer) As Integer
    'Returns integer division iA divided by iB in RealDiv().Good for small values.
    'Credit to Rebecca Gabriella's String Math Module with added edits.
    'https://cosxoverx.livejournal.com/47220.html
    
    If iB = 0 Then
        MsgBox "Divide by zero in RealDiv()"
        Exit Function
    End If
    
    If iA Mod iB = 0 Then
        RealDiv = iA \ iB
    ElseIf iA < 0 Then
        RealDiv = iA \ iB - 1 'round down
    Else
        RealDiv = iA \ iB
    End If

End Function

Public Function Subtract(ByVal sA As String, ByVal sB As String) As String
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns sA minus sB as string integer in Subtract()
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
    Dim iA As Integer, iB As Integer, iComp As Integer
    
    'test for empty parameters
    If Len(sA) = 0 Or Len(sB) = 0 Then
        MsgBox "Empty parameter in Subtract()"
        Exit Function
    End If
        
    'handle some negative values with Add()
    bAN = (Left(sA, 1) = "-")
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2)
    If bBN Then sB = Mid(sB, 2)
    If bAN And bBN Then
        bRN = True
    ElseIf bBN Then
        Subtract = Add(sA, sB)
        Exit Function
    ElseIf bAN Then
        Subtract = "-" + Add(sA, sB)
        Exit Function
    Else
        bRN = False
    End If
    
    'get biggest value into variable sA
    iComp = Compare(sA, sB)
    If iComp = 0 Then     'parameters equal in size
        Subtract = "0"
        Exit Function
    ElseIf iComp < 0 Then 'sA < sB
        Subtract = sA     'so swop sA and sB
        sA = sB           'to ensure sA >= sB
        sB = Subtract
        bRN = Not bRN     'and reverse output sign
    End If
    iA = Len(sA)          'recheck lengths
    iB = Len(sB)
    iComp = 0
    Subtract = ""
        
    'subtract column by column
    Do While iA > 0 And iB > 0
        iComp = iComp + CInt(Mid(sA, iA, 1)) - CInt(Mid(sB, iB, 1))
        Subtract = CStr(RealMod(iComp, 10)) + Subtract
        iComp = RealDiv(iComp, 10)
        iA = iA - 1
        iB = iB - 1
    Loop
    'then assuming param sA is longer
    Do While iA > 0
        iComp = iComp + CInt(Mid(sA, iA, 1))
        Subtract = CStr(RealMod(iComp, 10)) + Subtract
        iComp = RealDiv(iComp, 10)
        iA = iA - 1
    Loop
    
    'remove any leading zeros from result
    Do While Len(Subtract) > 1 And Left(Subtract, 1) = "0"
        Subtract = Mid(Subtract, 2)
    Loop
    
    'decide about any negative signs
    If Subtract <> "0" And bRN Then
        Subtract = "-" + Subtract
    End If

End Function

Public Function Multiply(ByVal sA As String, ByVal sB As String) As String
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns sA times sB as string integer in Multiply()
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
    Dim m() As Long, iCarry As Long
    Dim iAL As Integer, iBL As Integer, iA As Integer, iB As Integer
        
    'test for empty parameters
    If Len(sA) = 0 Or Len(sB) = 0 Then
        MsgBox "Empty parameter in Multiply()"
        Exit Function
    End If
        
    'handle any negative signs
    bAN = (Left(sA, 1) = "-")
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2)
    If bBN Then sB = Mid(sB, 2)
    bRN = (bAN <> bBN)
    iAL = Len(sA)
    iBL = Len(sB)
    
    'perform long multiplication without carry in notional columns
    ReDim m(1 To (iAL + iBL - 1)) 'expected length of product
    For iA = 1 To iAL
        For iB = 1 To iBL
            m(iA + iB - 1) = m(iA + iB - 1) + CLng(Mid(sA, iAL - iA + 1, 1)) * CLng(Mid(sB, iBL - iB + 1, 1))
        Next iB
    Next iA
    iCarry = 0
    Multiply = ""
    
    'add up column results with carry
    For iA = 1 To iAL + iBL - 1
        iCarry = iCarry + m(iA)
        Multiply = CStr(iCarry Mod 10) + Multiply
        iCarry = iCarry \ 10
    Next iA
    Multiply = CStr(iCarry) + Multiply
    
    'remove any leading zeros
    Do While Len(Multiply) > 1 And Left(Multiply, 1) = "0"
        Multiply = Mid(Multiply, 2)
    Loop
    
    'decide about any negative signs
    If Multiply <> "0" And bRN Then
        Multiply = "-" + Multiply
    End If

End Function

Public Function PartialDivide(ByVal sA As String, ByVal sB As String) As PartialDivideInfo
    'Called only by Divide() to assist in fitting trials for long division
    'All of Quotient, Subtrahend, and Remainder are returned as elements of type PartialDivideInfo
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
        
    For PartialDivide.Quotient = 9 To 1 Step -1                                'propose a divisor to fit
        PartialDivide.Subtrahend = Multiply(sB, CStr(PartialDivide.Quotient))  'test by multiplying it out
        If Compare(PartialDivide.Subtrahend, sA) <= 0 Then                     'best fit found
            PartialDivide.Remainder = Subtract(sA, PartialDivide.Subtrahend)   'get remainder
            Exit Function                                                      'exit with best fit details
        End If
    Next PartialDivide.Quotient
    
    'no fit found, divisor too big
    PartialDivide.Quotient = 0
    PartialDivide.Subtrahend = "0"
    PartialDivide.Remainder = sA

End Function

Public Function Divide(ByVal sA As String, ByVal sB As String) As String
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns sA divided by sB as string integer in Divide()
    'The remainder is available as sLastRemainder at Module level
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN  As Boolean, bBN As Boolean, bRN As Boolean
    Dim iC As Integer
    Dim s As String
    Dim d As PartialDivideInfo
    
    'test for empty parameters
    If Len(sA) = 0 Or Len(sB) = 0 Then
        MsgBox "Empty parameter in Divide()"
        Exit Function
    End If
    
    bAN = (Left(sA, 1) = "-") 'true for neg
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2) 'take two charas if neg
    If bBN Then sB = Mid(sB, 2)
    bRN = (bAN <> bBN)
    If Compare(sB, "0") = 0 Then
        Err.Raise 11
        Exit Function
    ElseIf Compare(sA, "0") = 0 Then
        Divide = "0"
        sLastRemainder = "0"
        Exit Function
    End If
    iC = Compare(sA, sB)
    If iC < 0 Then
        Divide = "0"
        sLastRemainder = sA
        Exit Function
    ElseIf iC = 0 Then
        If bRN Then
            Divide = "-1"
        Else
            Divide = "1"
        End If
        sLastRemainder = "0"
        Exit Function
    End If
    Divide = ""
    s = ""
    
    'Long division method
    For iC = 1 To Len(sA)
        'take increasing number of digits
        s = s + Mid(sA, iC, 1)
        d = PartialDivide(s, sB) 'find best fit
        Divide = Divide + CStr(d.Quotient)
        s = d.Remainder
    Next iC
    
    'remove any leading zeros
    Do While Len(Divide) > 1 And Left(Divide, 1) = "0"
        Divide = Mid(Divide, 2)
    Loop
    
    'decide about the signs
    If Divide <> "0" And bRN Then
        Divide = "-" + Divide
    End If
    
    sLastRemainder = s 'string integer remainder

End Function

Public Function LastModulus() As String
    LastModulus = sLastRemainder
End Function

Public Function Modulus(ByVal sA As String, ByVal sB As String) As String
    Divide sA, sB
    Modulus = sLastRemainder
End Function

Public Function BigIntFromString(ByVal sIn As String, ByVal iBaseIn As Integer) As String
    'Returns base10 integer string from sIn of different base (iBaseIn).
    'Example for sIn = "1A" and iBaseIn = 16, returns the base10 result 26.
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
            
    Dim bRN As Boolean
    Dim sBS As String
    Dim iP As Integer, iV As Integer
    
    'test for empty parameters
    If Len(sIn) = 0 Or iBaseIn = 0 Then
        MsgBox "Bad parameter in BigIntFromString()"
        Exit Function
    End If
        
    'handle negative signs
    If Left(sIn, 1) = "-" Then
        bRN = True
        sIn = Mid(sIn, 2)
    Else
        bRN = False
    End If
    sBS = CStr(iBaseIn)
    
    BigIntFromString = "0"
    For iP = 1 To Len(sIn)
        'use constant list position and base for conversion
        iV = InStr(Alphabet, UCase(Mid(sIn, iP, 1)))
        If iV > 0 Then 'accumulate
            BigIntFromString = Multiply(BigIntFromString, sBS)
            BigIntFromString = Add(BigIntFromString, CStr(iV - 1))
        End If
    Next iP
    
    'decide on any negative signs
    If bRN Then
        BigIntFromString = "-" + BigIntFromString
    End If

End Function

Public Function BigIntToString(ByVal sIn As String, ByVal iBaseOut As Integer) As String
    'Returns integer string of specified iBaseOut (iBaseOut) from base10 (sIn) integer string.
    'Example for sIn = "26" and iBaseOut = 16, returns the output "1A".
    'Credit to Rebecca Gabriella'sIn String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
            
    Dim bRN As Boolean
    Dim sB As String
    Dim iV As Integer
    
    'test for empty parameters
    If Len(sIn) = 0 Or iBaseOut = 0 Then
        MsgBox "Bad parameter in BigIntToString()"
        Exit Function
    End If
    
    'handle negative signs
    If Left(sIn, 1) = "-" Then
        bRN = True
        sIn = Mid(sIn, 2)
    Else
        bRN = False
    End If
    sB = CStr(iBaseOut)
    
    BigIntToString = ""
    Do While Compare(sIn, "0") > 0
        sIn = Divide(sIn, sB)
        iV = CInt(LastModulus())
        'locates appropriate alphabet character
        BigIntToString = Mid(Alphabet, iV + 1, 1) + BigIntToString
    Loop
    
    'decide on any negative signs
    If BigIntToString = "" Then
        BigIntToString = "0"
    ElseIf BigIntToString <> "0" And bRN Then
        BigIntToString = "-" + BigIntToString
    End If

End Function

Added Big Math Fuctions[edit | edit source]

  • Factorial() makes use of Multiply() and other integer math functions of the main module. It is of course fairly slow but is not otherwise limited in any practical way. The code has been arbitrarily limited to calculating values up to 1000!, but this can be adjusted by the user. DoEvents is important here, since it allows breaking the run if an unwise attempt is made. Reciprocal factorials and negative factorials are not handled here.
  • IntStrByExp() raises integer strings to an exponent. Again, negative exponents cannot yet be handled in this procedure, though the number to raise can take a negative value.
Sub testFactorial()
   'Run this to test factorial
      
   Dim sIn As Integer, sOut As String
   
   sIn = "400"
   sOut = Factorial(sIn)
   
   'output Immediate Window
   Debug.Print sIn & "!" & vbCrLf & _
               sOut & vbCrLf & _
               Len(sOut) & " digits" & vbCrLf
   
   'output message box - short output
   'MsgBox sIn & "!" & vbcrlf & _
           sOut & vbCrLf & _
           Len(sOut) &  " digits" & vbCrLf

End Sub

Function Factorial(ByVal sA As String) As String
    'Returns integer string factorial for integer string parameter sA
    '2000! in 30 secs (5736 digits); 1000! in six seconds (2568 digits)
    '400! in one second (869 digits);100! pdq (158 digits).
    'Arbitrarily set max sA = "1000"
    
    Dim iC As Integer
        
    'avoid excessively long runs
    If CInt(sA) >= 1000 Then
        MsgBox "Run time too long - closing."
        Factorial = "Error - Run time too long"
        Exit Function
    End If
        
    iC = CInt(sA)
    Factorial = "1"
    
    'run factorial loop
    Do Until iC <= 0
        DoEvents 'permits break key use
        Factorial = Multiply(Factorial, iC)
        iC = iC - 1
    Loop

End Function

Sub testIntStrByExp()
   'Run this to test IntStrByExp
      
   Dim sIn As String, sOut As String, iExp As Integer, bA As Boolean
   Dim nL As Integer
   
   
   sIn = "-123456789123456789"
   iExp = 7
   
   sOut = IntStrByExp(sIn, iExp)
   nL = Len(sOut)
   If Left(sOut, 1) = "-" Then
   nL = nL - 1
   End If
   
   'output Immediate Window
   Debug.Print sIn & "^" & iExp & " equals" & vbCrLf & _
               sOut & vbCrLf & _
               nL & " digits out" & vbCrLf
   
   'output message box - short output
   MsgBox sIn & "^" & iExp & " equals" & vbCrLf & _
               sOut & vbCrLf & _
               nL & " digits out" & vbCrLf

End Sub

Function IntStrByExp(ByVal sA As String, ByVal iExp As Integer) As String
    'Returns integer string raised to exponent iExp as integer string
    'Assumes posiive exponent, and pos or neg string integer
    
    Dim bA As Boolean, bR As Boolean
    
    'check parameter
    If iExp < 0 Then
        MsgBox "Cannot handle negative powers yet"
        Exit Function
    End If
    
    'handle any negative signs
    bA = (Left(sA, 1) = "-")
    If bA Then sA = Mid(sA, 2) Else sA = Mid(sA, 1)
    If bA And RealMod(iExp, 2) <> 0 Then bR = True
    
    'run multiplication loop
    IntStrByExp = "1"
    Do Until iExp <= 0
        DoEvents 'permits break key use
        IntStrByExp = Multiply(IntStrByExp, sA)
        iExp = iExp - 1
    Loop

    'remove any leading zeros
    Do While Len(IntStrByExp) > 1 And Left(IntStrByExp, 1) = "0"
        IntStrByExp = Mid(IntStrByExp, 2)
    Loop
    
    'decide on any signs
    If IntStrByExp <> "0" And bR Then
       IntStrByExp = "-" & IntStrByExp
    End If

End Function

See Also[edit | edit source]

External Links[edit | edit source]


Excel Sheet True Used Range

Summary[edit | edit source]

  • This code listing is for Excel. The procedure GetUsedRange returns the true used range of the Worksheet in the function name. An example is also given below of its use in the procedure WorkRangeInArray. It can typically be used to find the next writing position on a worksheet, but in any case returns all of the cell limits on each run.
  • Reports on various internet sites describe problems with the built-in UsedRange function. The problem types, apart from errors of understanding, seem to be divided between issues concerning the number of cells scrolled and errors in reporting the used range itself. This author has been unable to reproduce errors in reporting the UsedRange but requests inputs from interested parties. Readers with a clear demonstration of the UsedRange problem might care to advise me of it in the Discussion tab of this page. It is true to say that the removal of cell content at the end of a worksheet will not result in a revised scrolled region, and the use of Ctrl-End will still travel to the old position after deletion. These two matters are not necessarily linked however, since this still happens even while the UsedRange is correctly reported. In the meantime this code module will obtain a true used range.
  • The procedure GetUsedRange approaches the used cells from the outer limits in all four directions, and then, after noting the first filled cells that it encounters for each direction, defines the overall range as the smallest bounding rectangle that fits the whole thing. It optionally returns the row and column bounds at the same time.
  • The procedure WorkRangeInArray makes use of GetUsedRange in an example that loads a source sheet range onto an array for work, then passes it back to a target sheet, same or other, at some specified or default position.

VBA Code Listing (Modified 3 Dec 2016)[edit | edit source]

Added descriptive variable names for GetUsedRange parameters in accordance with suggestion in Discussion.(3 Dec 2016)

Option Explicit
Sub TestGetUsedRange()
    'assumes that there is a block of filled cells on worksheet 1
    
    Dim rng As Range, t, wsS As Worksheet
    Dim fr As Long, lr As Long, fc As Long, lc As Long
    
    Set wsS = ThisWorkbook.Worksheets("Sheet1")
    Set wsT = ThisWorkbook.Worksheets("Sheet2")
    Set rng = GetUsedRange(wsS, fr, fc, lr, lc)
    
    'count the row and cols in range
    MsgBox (lr - fr + 1) & " Rows in the range"
    MsgBox (lc - fc + 1) & " Columns in the range"
    
    'get first row number and first col number in range
    MsgBox fr & " is first row number in the range"
    MsgBox fc & " is first col number in the range"
    
    'get last row number and last col number in range
    MsgBox lr & " is last row number in the range"
    MsgBox lc & " is last col number in the range"

End Sub

Function GetUsedRange(ws As Worksheet, Optional FirstUsedRow As Long, Optional FirstUsedColumn As Long, _
                      Optional LastUsedRow As Long, Optional LastUsedColumn As Long) As Range
    'gets an accurate used range
        
    Dim s As String, X As Long
    Dim rng As Range
    Dim r1Fixed As Long, c1Fixed As Long
    Dim r2Fixed As Long, c2Fixed As Long
    Dim r1 As Long, c1 As Long
    Dim r2 As Long, c2 As Long
    Dim i As Long
    
    Set GetUsedRange = Nothing
    
    'Start with Excel's UsedRange function since
    'any such Excel error results in wider limits
    Set rng = ws.UsedRange
    
    'get bounding cells for Excel's used range
    'that is, cells(r1,c1) to cells(r2,c2)
    r1 = rng.Row
    r2 = rng.Rows.Count + r1 - 1
    c1 = rng.Column
    c2 = rng.Columns.Count + c1 - 1
    
    'early exit for single cell or none used
    If r1 = r2 And c1 = c2 Then
        Set GetUsedRange = ws.Cells(r1, c1)
        FirstUsedRow = r1: LastUsedRow = r2: FirstUsedColumn = c1: LastUsedColumn = c2
        Exit Function
    Else
        'continue to find used range
    End If
        
    'save existing values
    r1Fixed = r1
    c1Fixed = c1
    r2Fixed = r2
    c2Fixed = c2
    
    'check rows from top down for all blanks
    'if found shrink rows
    For i = 1 To r2Fixed - r1Fixed + 1
        If Application.CountA(rng.Rows(i)) = 0 Then
            'empty row -- reduce
            r1 = r1 + 1
        Else
            'nonempty row, get out
            Exit For
        End If
    Next
    
    'repeat for columns from left to right
    For i = 1 To c2Fixed - c1Fixed + 1
        If Application.CountA(rng.Columns(i)) = 0 Then
            'empty row -- reduce
            c1 = c1 + 1
        Else
            'nonempty row, get out
            Exit For
        End If
    Next
    
    'reset the range
    Set rng = ws.Range(ws.Cells(r1, c1), ws.Cells(r2, c2))
    
    'start again
    r1Fixed = r1
    c1Fixed = c1
    r2Fixed = r2
    c2Fixed = c2
    
    'do rows from bottom up
    For i = r2Fixed - r1Fixed + 1 To 1 Step -1
        If Application.CountA(rng.Rows(i)) = 0 Then
            r2 = r2 - 1
        Else
            Exit For
        End If
    Next
    
    'repeat for columns from right to left
    For i = c2Fixed - c1Fixed + 1 To 1 Step -1
        If Application.CountA(rng.Columns(i)) = 0 Then
            c2 = c2 - 1
        Else
            Exit For
        End If
    Next
    
    'set output parameters
    Set GetUsedRange = ws.Range(ws.Cells(r1, c1), ws.Cells(r2, c2))
    FirstUsedRow = r1: LastUsedRow = r2: FirstUsedColumn = c1: LastUsedColumn = c2

End Function


Sub TestWorkRangeInArray()
    'place a block of data in Sheet 1 before run
    'transfers data via a work array to Sheet 2
    
    Dim wsS As Worksheet, wsT As Worksheet
    
    Set wsS = ThisWorkbook.Worksheets("Sheet1")
    Set wsT = ThisWorkbook.Worksheets("Sheet2")
    
    'used range of sheet 1 to sheet 2,
    'to new top left start position r,c = 5,13
    WorkRangeInArray wsS, wsT, 5, 13
    
    Set wsS = Nothing
    Set wsT = Nothing

End Sub

Function WorkRangeInArray(wsSrc As Worksheet, wsTarg As Worksheet, Optional PosR As Long, _
                                 Optional PosC As Long) As Boolean
    'loads target sheet range into a work array
    'user should add array work to middle section, or not, if just for transfer
    'writes work array onto target worksheet, or same if so specified
    'optional target sheet position, defaults to same as source
    
    Dim vArr As Variant, rngSrc As Range, rngTarg As Range
    Dim fr As Long, fc As Long, lr As Long, lc As Long
    Dim nRowsSrc As Long, nColsSrc As Long, nRowsTarg As Long, nColsTarg As Long
    
    'Load target sheet range onto the work array
    
        'gets true used range and its row/col number limits
        Set rngSrc = GetUsedRange(wsSrc, fr, fc, lr, lc)
        
        'load values into array
        If rngSrc.Cells.Count = 1 Then
            ReDim vArr(1 To 1, 1 To 1)
            vArr(1, 1) = rngSrc.Value
        Else
            vArr = rngSrc
        End If
        
    'User can place array working here, if needed
    'note that code below expects same array for output
        
    'Write work array to position on the target sheet
                
        'activate target sheet
        wsTarg.Activate
        
        'decide sheet positon for target data
        If PosR > 0 And PosC > 0 Then 'use parameter position values
            Set rngTarg = wsTarg.Cells(PosR, PosC)
        Else
            Set rngTarg = wsTarg.Cells(fr, fc) 'position same as source
        End If
                
        'extend target range to fit
        Set rngTarg = rngTarg.Resize(UBound(vArr, 1), UBound(vArr, 2))
        
        'transfer array data to target sheet
        rngTarg = vArr
        
    'Release object variables
        Set rngSrc = Nothing
        Set rngTarg = Nothing
        Set wsSrc = Nothing
        Set wsTarg = Nothing

     'Transfers
     WorkRangeInArray = True

End Function


Bubble Sort One Dimensional Arrays

Summary[edit | edit source]

This page deals with the sorting of single dimensioned arrays. These are typically the ones used for placing lists into variants with the Array method. It is more rare to find such a sorting routine in VBA, since most sorting is done in two dimensions.

Bubble Sorting One Dimensional Arrays[edit | edit source]

  • The procedure BubbleSort1DArray() uses the slowest of sorting methods. However, there would seem to be no disadvantage in doing so here, since few lists ever attain great size. There are options for ascending or descending sorts, and for the method of return. If a return array is provided, that will be used, otherwise the input array will be changed by returning in that.

The Code Module[edit | edit source]

Function BubbleSort1DArray(vIn As Variant, bAscending As Boolean, Optional vRet As Variant) As Boolean
    ' Sorts the single dimension list array, ascending or descending
    ' Returns sorted list in vRet if supplied, otherwise in vIn modified
        
    Dim First As Long, Last As Long
    Dim i As Long, j As Long, bWasMissing As Boolean
    Dim Temp As Variant, vW As Variant
    
    First = LBound(vIn)
    Last = UBound(vIn)
    
    ReDim vW(First To Last, 1)
    vW = vIn
    
    If bAscending = True Then
        For i = First To Last - 1
            For j = i + 1 To Last
                If vW(i) > vW(j) Then
                Temp = vW(j)
                vW(j) = vW(i)
                vW(i) = Temp
                End If
            Next j
        Next i
    Else 'descending sort
        For i = First To Last - 1
            For j = i + 1 To Last
                If vW(i) < vW(j) Then
                Temp = vW(j)
                vW(j) = vW(i)
                vW(i) = Temp
                End If
            Next j
        Next i
    End If
  
   'find whether optional vRet was initially missing
    bWasMissing = IsMissing(vRet)
   
   'transfers
   If bWasMissing Then
     vIn = vW  'return in input array
   Else
     ReDim vRet(First To Last, 1)
     vRet = vW 'return with input unchanged
   End If
   
   BubbleSort1DArray = True

End Function


Bubble Sort on One Key

Summary[edit | edit source]

This page is intended for procedures that sort on two dimensions. Further, since some make use of multisort methods, this page is restricted to sorting on a single key. That is, using one column or row as the basis of the sort.

Bubble Sort Arrays in VBA[edit | edit source]

  • The procedure is for sorting a two dimensional array. This is perhaps the most common requirement. The options allow for column or row sorts, choice of sort index, and the choice of ascending or descending sorts. There is again, a choice of returning the sorted work in a different array with the input intact, or if not supplied, returning it with the original changed.
  • The bubble sort's speed is suitable for most VBA projects, though faster sorting algorithms are used for more demanding applications. Although not available for Excel, those who are using MS Word might consider calling the SortArray function of WordBasic instead. In Excel the WorksheetFunctions might bear some study as to their sorting usefulness.

The Code Module[edit | edit source]

Function SortArr2D1Key(ByRef vA As Variant, _
                       Optional ByVal bIsAscending As Boolean = True, _
                       Optional ByVal bIsRowSort As Boolean = True, _
                       Optional ByVal SortIndex As Long = -1, _
                       Optional ByRef vRet As Variant) As Boolean
'--------------------------------------------------------------------------------
' Procedure : SortArr2D1Key
' Purpose   : Bubblesorts a 2D array on 1 key, up or down, on any column or row.
'             Options include in-place, with the source changed, or
'             returned in vRet, with the source array intact.
'             Optional parameters default to: ROW SORT in place, ASCENDING,
'             using COLUMN ONE as the key.
'--------------------------------------------------------------------------------
    
    Dim condition1 As Boolean, vR As Variant
    Dim i As Long, j As Long, y As Long, t As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim r As Long, c As Long, bWasMissing As Boolean
    
    'find bounds of vA data input array
    loR = LBound(vA, 1): hiR = UBound(vA, 1)
    loC = LBound(vA, 2): hiC = UBound(vA, 2)
    
    'find whether optional vR was initially missing
    bWasMissing = IsMissing(vRet)
    'If Not bWasMissing Then Set vRet = Nothing
    
    'check input range of SortIndex
    If bIsRowSort And (SortIndex < loC Or SortIndex > hiC) Then
        MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
        Exit Function
    Else:
    End If
    
    If Not bIsRowSort And (SortIndex < loR Or SortIndex > hiR) Then
        MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
        Exit Function
    Else:
    End If
    
    'pass to a work variable
    vR = vA
    
    'steer input options
    If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
    
ROWSORT:
    For i = loR To hiR - 1
        For j = loR To hiR - 1
            If bIsAscending Then
                condition1 = vR(j, SortIndex) > vR(j + 1, SortIndex)
            Else
                condition1 = vR(j, SortIndex) < vR(j + 1, SortIndex)
            End If
            If condition1 Then
                For y = loC To hiC
                    t = vR(j, y)
                    vR(j, y) = vR(j + 1, y)
                    vR(j + 1, y) = t
                Next y
            End If
        Next
    Next
    GoTo TRANSFERS
    
COLSORT:
    For i = loC To hiC - 1
        For j = loC To hiC - 1
            If bIsAscending Then
                condition1 = vR(SortIndex, j) > vR(SortIndex, j + 1)
            Else
                condition1 = vR(SortIndex, j) < vR(SortIndex, j + 1)
            End If
            If condition1 Then
                For y = loR To hiR
                    t = vR(y, j)
                    vR(y, j) = vR(y, j + 1)
                    vR(y, j + 1) = t
                Next y
            End If
        Next
    Next
    GoTo TRANSFERS
    
TRANSFERS:
    'decide whether to return in vA or vRet
    If Not bWasMissing Then
        'vRet was the intended return array
        'so return vRet leaving vA intact
        vRet = vR
    Else:
        'vRet is not intended return array
        'so reload vA with vR
        vA = vR
    End If
    
    'set return function value
    SortArr2D1Key = True
    
End Function


Bubble Sort on Multiple Keys

Summary[edit | edit source]

Array Sort on Three Keys[edit | edit source]

  • This rather long VBA code listing allows bubble sorting of an array on three keys. It is sometimes called an intersort.
  • In case it is not clear what that means, suppose there are many names to sort; each with two forenames and a surname. The names records occupy a row each and their parts are in separate columns. The first key might sort the surnames column, but there could be many records called Smith. Then the second key sorts among the first forenames where the surnames were similar. And there might still be a lot of John Smith name records that are the same. The third key sorts the second forename column for those cases where there are records with the same surname and first forename combination.
  • A similar function can be found on Excel worksheets in the advanced sort functions. Users unfamiliar with this sort type might well experiment there to better understand the process.
  • The function here has options for ascending or descending sorts, row sort or column sort, and the option to return the sorted work in another array or the original. Up to three keys can be specified, though if there are unused keys, say, because only two intersorts are needed, it is assumed that Key1 and Key2 will be used before Key3. In any case, unreasonable settings will result in message box advice.
Function SortArr2D3Keys(vA As Variant, _
                        Optional Key1 As Long = -1, _
                        Optional Key2 As Long = -1, _
                        Optional Key3 As Long = -1, _
                        Optional ByVal bIsAscending As Boolean = True, _
                        Optional ByVal bIsRowSort As Boolean = True, _
                        Optional ByRef vR As Variant) As Boolean
'--------------------------------------------------------------------------------------
' Procedure : SortArr2D3Keys
' Purpose   : Bubblesorts a 2D array using 3 keys, up or down, on any column or row.
'             For example, sorting using up to three columns;
'             Eg; first sorts surnames, then sorts among same surnames for first names,
'             then among similar surnames with same first names for middle names.
'             Options include in-place, with the source changed, or
'             if supplied, returned in vR, with the source array intact.
'             Optional parameters default to: ROW SORT, ASCENDING.
'             Trailing key options that are not needed should be set to same as previous.
'---------------------------------------------------------------------------------------
    
ASSIGNMENTS:
    Dim condition1 As Boolean, vW As Variant, Temp
    Dim i As Long, j As Long, y As Long, t As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim r As Long, c As Long, bWasMissing As Boolean
    Dim sCombo As String, reply
    Dim b1Used As Boolean, b2Used As Boolean, b3Used As Boolean
    
    'find bounds of vA data input array
    loR = LBound(vA, 1): hiR = UBound(vA, 1)
    loC = LBound(vA, 2): hiC = UBound(vA, 2)
    
    'find whether optional vR was initially missing
    bWasMissing = IsMissing(vR)
    If Not bWasMissing Then Set vR = Nothing
    
KEYCHECKS:
    If Key1 <> -1 Then
        b1Used = True
        'check key within bounds
        If bIsRowSort And (Key1 < loC Or Key1 > hiC) Then
            MsgBox "Sort key1 out of bounds"
            Exit Function
        End If
        If Not bIsRowSort And (Key1 < loR Or Key1 > hiR) Then
            MsgBox "Sort key1 out of bounds"
            Exit Function
        End If
    End If
    
    If Key2 <> -1 Then
        b2Used = True
        'check key within bounds
        If bIsRowSort And (Key2 < loC Or Key2 > hiC) Then
            MsgBox "Sort key2 out of bounds"
            Exit Function
        End If
        If Not bIsRowSort And (Key2 < loR Or Key2 > hiR) Then
            MsgBox "Sort key2 out of bounds"
            Exit Function
        End If
    End If
    
    If Key3 <> -1 Then
        b3Used = True
        'check key within bounds
        If bIsRowSort And (Key3 < loC Or Key3 > hiC) Then
            MsgBox "Sort key3 out of bounds"
            Exit Function
        End If
        If Not bIsRowSort And (Key3 < loR Or Key3 > hiR) Then
            MsgBox "Sort key3 out of bounds"
            Exit Function
        End If
    End If
    
    sCombo = CStr(Abs(b1Used)) & CStr(Abs(b2Used)) & CStr(Abs(b3Used))
    'MsgBox sCombo
    
    Select Case sCombo
    Case "000"
        'no keys selected
        If bIsRowSort Then
           reply = MsgBox("No keys selected." & vbCrLf & _
           "Use lower bound column for a single key?", vbCritical + vbQuestion + vbYesNo, "Please confirm your selection...")
           Select Case reply
           Case vbYes
               Key1 = loC
           Case Else
               Exit Function
           End Select
        Else
           reply = MsgBox("No keys selected." & vbCrLf & _
           "Use lower bound row for a single key?", vbCritical + vbQuestion + vbYesNo, "Please confirm your selection...")
           Select Case reply
           Case vbYes
               Key1 = loR
           Case Else
               Exit Function
           End Select
        End If
    Case "100", "110", "111"
        'proceed normally
    Case Else
        MsgBox "Only three combinations of sort keys are possible" & vbCrLf & _
        "Key1 alone, Key1 with Key2, or Key1 with Key2 and Key3."
        Exit Function
    End Select
    
WORKARRAY:
    'use a working array for sorting
    vW = vA
    
STEERING:
    'steer input options
    If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
    
ROWSORT:
    'row sort using 3 intersort keys
    'Sort rows of array using first column index, Key1
    For i = loR To hiR - 1
        For j = i + 1 To hiR
            'set < for descending, and > for ascending
            If bIsAscending Then
                condition1 = vW(i, Key1) > vW(j, Key1)
            Else
                condition1 = vW(i, Key1) < vW(j, Key1)
            End If
            If condition1 Then
                For c = loC To hiC
                    Temp = vW(i, c)
                    vW(i, c) = vW(j, c)
                    vW(j, c) = Temp
                Next
            End If
        Next
    Next
    If b2Used Then
        'Sort rows of array using second column index, Key2
        For i = loR To hiR - 1
            For j = i + 1 To hiR
                'if-condition avoids independence of second sort
                'note that a third stage would have THREE terms
                If vW(i, Key1) = vW(j, Key1) Then
                    'set < for descending, and > for ascending
                    If bIsAscending Then
                        condition1 = vW(i, Key2) > vW(j, Key2)
                    Else
                        condition1 = vW(i, Key2) < vW(j, Key2)
                    End If
                    If condition1 Then
                        For c = loC To hiC
                            Temp = vW(i, c)
                            vW(i, c) = vW(j, c)
                            vW(j, c) = Temp
                        Next
                    End If
                End If
            Next
        Next
    Else
        GoTo TRANSFERS
    End If
    If b3Used Then
        'Sort rows of array using third column index, Key3
        For i = loR To hiR - 1
            For j = i + 1 To hiR
                'if-condition avoids independence of second sort
                'note that a third stage would have THREE terms
                If vW(i, Key1) = vW(j, Key1) And vW(i, Key2) = vW(j, Key2) Then
                    'set < for descending, and > for ascending
                    If bIsAscending Then
                        condition1 = vW(i, Key3) > vW(j, Key3)
                    Else
                        condition1 = vW(i, Key3) < vW(j, Key3)
                    End If
                    If condition1 Then
                        For c = loC To hiC
                            Temp = vW(i, c)
                            vW(i, c) = vW(j, c)
                            vW(j, c) = Temp
                        Next
                    End If
                End If
            Next
        Next
    End If
    GoTo TRANSFERS
   
COLSORT:
    'column sort using 3 intersort keys
    'Sort columns of array using first row index, Key1
    For i = loC To hiC - 1
        For j = i + 1 To hiC
            'set < for descending, and > for ascending
            If bIsAscending Then
                condition1 = vW(Key1, i) > vW(Key1, j)
            Else
                condition1 = vW(Key1, i) < vW(Key1, j)
            End If
            If condition1 Then
                For c = loR To hiR
                    Temp = vW(c, i)
                    vW(c, i) = vW(c, j)
                    vW(c, j) = Temp
                Next
            End If
        Next
    Next
    If b2Used Then
        'Sort columns of array using second row index, Key2
        For i = loC To hiC - 1
            For j = i + 1 To hiC
                'if-condition avoids independence of second sort
                'note that a third stage would have THREE terms
                If vW(Key1, i) = vW(Key1, j) Then
                    'set < for descending, and > for ascending
                    If bIsAscending Then
                        condition1 = vW(Key2, i) > vW(Key2, j)
                    Else
                        condition1 = vW(Key2, i) < vW(Key2, j)
                    End If
                    If condition1 Then
                        For c = loR To hiR
                            Temp = vW(c, i)
                            vW(c, i) = vW(c, j)
                            vW(c, j) = Temp
                        Next
                    End If
                End If
            Next
        Next
    Else
        GoTo TRANSFERS
    End If
    If b3Used Then
        'Sort columns of array using third  row index, Key2
        For i = loC To hiC - 1
            For j = i + 1 To hiC
                'if-condition avoids independence of second sort
                'note that a third stage would have THREE terms
                If vW(Key1, i) = vW(Key1, j) And vW(Key2, i) = vW(Key2, j) Then
                    'set < for descending, and > for ascending
                    If bIsAscending Then
                        condition1 = vW(Key3, i) > vW(Key3, j)
                    Else
                        condition1 = vW(Key3, i) < vW(Key3, j)
                    End If
                    If condition1 Then
                        For c = loR To hiR
                            Temp = vW(c, i)
                            vW(c, i) = vW(c, j)
                            vW(c, j) = Temp
                        Next
                    End If
                End If
            Next
        Next
    End If
    GoTo TRANSFERS
    
TRANSFERS:
    'decide whether to return in vA or vR
    If Not bWasMissing Then
        'vR was the intended return array
        'so return vR leaving vA intact
        vR = vW
    Else:
        'vR is not intended
        'so reload vA with vR
        vA = vW
    End If
    
    'set return function value
    SortArr2D3Keys = True
    
End Function


Variable Beep from VBA

Summary[edit | edit source]

Figure1:A table of note frequencies with their positional distances from 440Hz.The frequency of any note can be calculated with Frequency = 440 * (2 ^ (n/12)), where n is the distance. Sharps are marked with hash marks (#) and flats with b, otherwise notes are naturals.The notes with two designations occur because the half-note shifting of flats and sharps causes some to have the same frequency.
Figure 2: Simple music score for Ode to Joy with note names and distances from A = 440Hz. The reference point to assign distances is G, always on the second line when using the treble clef.
Figure 3: The international morse code.

This VBA code module examines various uses of the Beep() API. Its parameters are frequency and duration. It has no wait parameter, so chords are not possible, just simple tones. It is stated to work well for Windows 7 versions onwards, but might ignore the parameters for earlier versions. Simple musical scales and tunes are illustrated, in addition to a Morse code text sender.

Beep API Bugs[edit | edit source]

In the past many problems were found in the use of the Beep API. Since Windows 7, the Beep API has been re-coded by Microsoft to work with computer sound cards. Prior to Windows 7, the API functioned only with an on-board sound chip. Unfortunately, during the transition from sound chips to sound cards, some computer manufacturers still used chips while others used cards. This is the basis of the problem for older Windows versions. No problems should be encountered in the use of the Beep API for recent builds.

Procedure Notes[edit | edit source]

Several procedures are provided in the module. Copy the entire code into a standard module for testing. The procedures are as follows:

  • Beeper() is the basic form of the function. Running it will make a simple tone in the computer's speakers. Note that it does not refer to the alert sounder that is built into Windows, but the speakers used for listening to media. Both the frequency and duration of the sound can be adjusted, though the consistency of the output, being designed for selected frequency use is not very good.
  • TestNotes() expands on the basic format. Run this to produce up and down scales. There are two ways to access frequencies:
    • The first is just to enter the exact frequencies for each note in a sequence of code lines; this is the case for the do re me scales, the so-called natural notes, eg, C,D,E,F,G,A,B,C....
    • The other, when the exact frequencies are not known is to use a formula to calculate the frequency based on knowledge of the relative position of the note with respect to a reference point. (See Figures 1 and 2). The reference point in this case is note A = 440 Hz. Figure 1 shows three octaves of notes around 440Hz, and Figure 2 shows how notes in a simple music score relate to note distance. The note-distance value can be used to calculate frequency for any other note. For example, in Figure 2, notice that the G notes have a distance of 10; this and all other note distances are listed in the table of Figure 1. When it is understood that G notes always occupy the second line of the treble clef, a simple score can be marked with both notes and distances, ready for coding.
  • SendMorse() sounds out the Morse code for a parameter string. The procedure gives a basic output, with adjustable frequency (Hz) and dot length (milliseconds).
    • Delays are introduced with Delay() for the inter-element (one dot), inter-character (3 dots), and inter-word (7 dots) intervals, in addition to the basic one to three ratio for dots and dashes. All timing is derived from the length of one short dot element. A random element can be added to all timing in Random(), where the maximum percentage of error can be set; this is said to better resemble a human hand rather that the too-perfect program.
    • The convention is to estimate words per minute in terms of dot duration also, as T = 1200 / W where T is dot duration in milliseconds and W is the generated number of words per minute. The international Morse code is given for reference in Figure 3.

The Code[edit | edit source]

  • Modified 24 Dec 18 to add randomness to all timing in SendMorse()
  • Modified 24 Dec 18 to add an omitted sCode declaration in SendMorse()
  • Modified 23 Dec 18 to correct data in SendMorse() array vSN
  • Modified 22 Dec 18 to show use of note distance in a tune.
  • Modified 21 Dec 18 to correct timing errors for Morse code procedures.

Run TestBeeper(), TestNotes(), or testSendMorse() to run the various procedures.

Option Explicit
Public Declare PtrSafe Function BeepAPI Lib "kernel32" Alias "Beep" _
             (ByVal Frequency As Long, ByVal Milliseconds As Long) As Long

Sub TestBeeper()
    'run this to test beeper
    
    Dim nFreq As Long, nDur As Long

    nFreq = 800     'frequency (Hertz)
    nDur = 500   'duration (milliseconds)

    'call beeper function
    Beeper nFreq, nDur

End Sub

Function Beeper(nF As Long, nD As Long) As Boolean
    'makes a beep sound of selected frequency and duration
    'This works for NT/2000/XP and beyond.
    'Before that, frequency and duration ignored.
    
    BeepAPI nF, nD

    Beeper = True

End Function

Sub TestNotes()
    'music notes played using known frequencies and those
    'calculated from knowlege of their relative positions'
        
    Dim vAN As Variant, vOTJ As Variant, vOTJD As Variant
    Dim i As Long, nFreq As Long
    Dim nDur As Long, nLen As Long

    'sets the basic note duration
    nDur = 500

    'store the specific frequencies in array - zero based...
    'these frequencies are for do,re,me,fa,so,la,te,do based on middle C =261.63Hz (262)
    'CDEFGABC
    vAN = Array(262, 294, 330, 349, 392, 440, 494, 523)
    
    'or store a jingle in note difference notation. Ode To Joy on beeper.
    vOTJ = Array(7, 7, 8, 10, 10, 8, 7, 5, 3, 3, 5, 7, 7, 5, 5) 'note positions from 440Hz
    vOTJD = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2)  'durations
    
    'scales up
    'CDEFGABC
    'do re me fa so la te do
    For i = 0 To 7
        nFreq = vAN(i)
        BeepAPI nFreq, nDur
    Next i

    Delay 1000 'delay one second

    'scales down
    'CBAGFEDC
    'do te la so fa me re do
    For i = 7 To 0 Step -1
        nFreq = vAN(i)
        BeepAPI nFreq, nDur
    Next i

    Delay 1000 'delay one second

    '34 notes, naturals, sharps and flats
    'played using note position from 440Hz
    For i = -5 To 28
        nFreq = CInt(440 * 2 ^ (i / 12))
        BeepAPI nFreq, nDur
    Next i

    Delay 1000 'delay one second

    'Ode to Joy - albeit crude, using note distance only
    For i = 0 To 14
       nFreq = CInt(440 * 2 ^ (vOTJ(i) / 12))
       BeepAPI nFreq, 400 * vOTJD(i)
    Next i
   
   Delay 1000 'delay one second
   
   'or use direct entries to make a custom sound
    BeepAPI 262 * 2, 200
    BeepAPI 494 * 2, 200
    BeepAPI 494 * 2, 200
    BeepAPI 262 * 2, 500
    
End Sub

Sub testSendMorse()
    'run this to test the Morse code sender
    'integers and simple alphabet only
    
    Dim sIn As String
    Dim start As Single, ends As Single
    
    sIn = "The quick brown fox jumps over the lazy dog 0123456789 times"
    
    'start = Timer
    SendMorse sIn, 440, 120 'string,freq (Hz),dot length (mS)

    'ends = Timer - start
    'MsgBox ends
End Sub

Sub SendMorse(ByVal sIn As String, nUF As Single, nUL As Single)
    'Sounds out Morse code for input string sIn
    'Parmeters frequency(Hz) and dot length(mS)

    Dim vSL As Variant, vSN As Variant, vM As Variant
    Dim i As Long, j As Long, nAsc As Integer
    Dim sWord As String, sCode As String

    'check that there is a decent string input
    If Trim(sIn) = "" Then
        MsgBox "Illegal characters in input string - closing"
        Exit Sub
    End If
        
    'load letter array with morse code- 1 for dot and 3 for dah
    vSL = Array("13", "3111", "3131", "311", "1", "1131", "331", "1111", "11", _
                "1333", "313", "1311", "33", "31", "333", "1331", "3313", "131", _
                "111", "3", "113", "1113", "133", "3113", "3133", "3311") 'a,b,c,...z
    'load number array with morse code- 1 for dot and 3 for dah
    vSN = Array("33333", "13333", "11333", "11133", "11113", _
                "11111", "31111", "33111", "33311", "33331")              '0,1,2,...9
        
    'split the input string into words
    vM = Split(Trim(sIn), " ") 'zero based
    
    For i = LBound(vM) To UBound(vM) 'step through words
        'get one word at a time
        sWord = LCase(vM(i)) 'current word
        'get one chara at a time
        For j = 1 To Len(sWord)
            'look up chara asci code
            nAsc = Asc(Mid(sWord, j, 1))
            'get morse sequence from array
            Select Case nAsc
                Case 97 To 122 'a letter
                    sCode = vSL(nAsc - 97)
                    MakeBeeps sCode, nUL, nUF
                    If j <> Len(sWord) Then
                        Delay (nUL * 3) 'add 3 spaces between letters
                    End If
                Case 48 To 57  'an integer
                    sCode = vSN(nAsc - 48)
                    MakeBeeps sCode, nUL, nUF
                    If j <> Len(sWord) Then
                        Delay (nUL * 3) 'add 3 spaces between letters
                    End If
                Case Else
                    MsgBox "Illegal character in input" & vbCrLf & _
                           "Only A-Z and 0-9 permitted."
            End Select
            
        Next j
        If i <> UBound(vM) Then Delay (nUL * 7) 'add 7 spaces between words
    Next i
    
End Sub
Function MakeBeeps(ByVal sIn As String, ByVal nUL As Single, ByVal nUF As Single) As Boolean
    'makes beep sounds for one character based on coded input string
    
    Dim i As Long, j As Long, nLen As Long
    Dim nT As Single, nE As Single
    
    For i = 1 To Len(sIn)
        'get character element
        nLen = CInt(Mid(sIn, i, 1))
        Select Case nLen
        Case 1
            BeepAPI nUF, nUL + Random(nUL)
            If i <> Len(sIn) Then Delay nUL
        Case 3
            BeepAPI nUF, (3 * nUL) + Random(3 * nUL)
            If i <> Len(sIn) Then Delay nUL
        Case Else
            MsgBox "error"
        End Select
    Next i
            
    MakeBeeps = True

End Function

Function Random(nDot As Single) As Single
    'adds a random variation to the timing
    'used to better hide machine code signature
    'nRand = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
    
    Dim nRand As Long, nPercent As Single
    Dim nU As Long, nL As Long
    
    'set a number here for max error percentage
    'eg; 10 for ten percent error, 0 for none.
    nPercent = 10 'max percent plus and minus

    'initialize the random generator
    Randomize
    
    'generate small random number as the timing error
    
    nRand = Int((nDot * nPercent / 100 + nDot * nPercent / 100 + 1) * Rnd - nDot * nPercent / 100)

    Random = nRand

End Function

Sub Delay(nD As Single)
    'delays for nD milliseconds
    'randomness set in Random()
    
    Dim start As Single
   
    nD = nD + Random(nD) 'add randomness to intention
    
    start = Timer  ' Set start time.
    Do While Timer < start + nD / 1000
        DoEvents    ' Yield to other processes.
    Loop

End Sub

See Also[edit | edit source]


Play a WAV File from VBA

Summary[edit | edit source]

  • This code module plays sounds in Excel VBA using existing .wav files. Many such files can be found in the C:\Windows\Media folder, and can be made from text with a suitable VBA procedure.
  • The procedure used is an API. This API code has been tested for Win10 64 bit with Excel 2019 64 bit, and works well.

Notes on the Code[edit | edit source]

  • The most general version that applies to all VBA uses an API function sndPlaySound. The code plays audio (WAV) files via the user's speakers as opposed to any internal sounders. Files must already exist on the user's PC for any sound that is played. In Excel, and when the user just needs to play strings, then the built-in Speak function is more convenient.
  • Notice that sndPlaySound makes use of a wait parameter. When assembling discrete sounds that are not intended to overlap, the function can be made to play its sound before allowing the next line of code to run. Conversely, to overlap a new note with the tail of an old note, as in the playing of piano keys, the next code line is allowed to run before the sound has completed. Setting the Wait parameter to False will cause the code to run on before completion.
  • Libraries of wav sound files can be downloaded from internet pages. They are generally organized for download in zipped files by category. That is to say, a set of spoken numbers, spoken letters, piano keys etc. If the ideal set is not available then there are several free text to wav file applications on the internet that can be downloaded and that allow sound files to be made from typed text, Readers might care to comment in the My discussion page about high quality file sets.
  • Quite complex constructions can be made by playing sound files in sequence. Possible applications include audio advice for the progress of long procedure runs, or sound punctuation of the type already used by Microsoft for the opening and closing of processes. Some individuals construct entire piano keyboards on user forms, complete with flats and sharps.
  • Readers who intend to use integers or letters for playback as a sequence might be interested to know:
    • The task of code writing is greatly simplified if the sound files' names start with the characters that they represent. For example, a file that expresses the sound for one is best called 1.wav, three as 3.wav, and similarly with the letter set. The reason is that a string character from code can be used to construct the name of the file to call. This allows single line calls in loops at times, compared to the accessing of lists of elaborately named files. See the procedure ReadIntegers for the method to use. Clearly, without the wav file set that goes with it, this procedure is of limited use to the reader.
    • The lead in and lead out times of sound files can make for a fairly halting delivery. To get around this, record a sound file with as much in the one file as possible, rather than depending on a sum of many to obtain the result.

VBA Code[edit | edit source]

Option Explicit

'Declaration for Win10 and Office 64 bit
Public Declare PtrSafe Function sndPlaySound Lib "winmm.dll" _
        Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
           ByVal uFlags As Long) As Long

Sub TestPlayWavFileAPI()
    'run this to play a sound wave (.wav) file
    
    Dim sPath As String
    
    'path to wave file - replace with your own
    sPath = "C:\Windows\Media\Ring08.wav"
    
    'test the no-wait feature
    PlayWavFileAPI sPath, False
    MsgBox "This message box appears during the sound"
    
    'test the wait feature
    PlayWavFileAPI sPath, True
    MsgBox "This message appears only after the sound stops"

End Sub

Function PlayWavFileAPI(sPath As String, Wait As Boolean) As Boolean
    'API declaration of sndPlaySound is modified for 64 bit windows
    'and tests well in Excel 2019 vba version 7.1.
    'For earlier versions it might be necessary to remove the word PtrSafe
    'from the declaration, or to consider another format.
    
    'make sure file exists
    If Dir(sPath) = "" Then
        Exit Function
    End If
    
    If Wait Then
        'hold up follow-on code until sound complete
        sndPlaySound sPath, 0
    Else
        'continue with code run while sound is playing
        sndPlaySound sPath, 1
    End If

End Function

See Also[edit | edit source]

External Links[edit | edit source]


Make a WAV File from a VBA String

Summary[edit | edit source]

  • This code module will make a voiced wav file starting from a VBA string. A reference should be set in the VBA editor to Microsoft Speech Object Library.
  • The parameters are just the intended string to be spoken and a full path to the intended file name. The process MAKES a file but does not speak it as audio. Once made, the wav file can be spoken with procedures in an adjacent page, or tested in Windows Explorer by simply opening it.
  • No error code has been added. For example, if an attempt is made to use a folder with restrictions, an error will be raised. Users might consider adding some error trapping.
  • The intended target wave file need not exist. If it does not exist it will be made. If it exists however, it will be overwritten.
  • Notice that the user should enter his own profile in the file path. This author could not make the environmental paths work which would otherwise have made the code independent of the profile details.

VBA Code[edit | edit source]

Copy the entire code listing into an Excel standard module. Modify the paths to your own, and run the top procedure to make a reusable wav file of the string. Remember to set a reference to Microsoft Speech Object Library.

Option Explicit
Sub TestStringToWavFile()
    'run this to make a wav file from a text input

    Dim sP As String, sFN As String, sStr As String, sFP As String

    'set parameter values - insert your own profile name first
    'paths
    sP = "C:\Users\Your Profile Name\Documents\" 'for example
    sFN = "Mytest.wav" 'overwrites if file name same
    sFP = sP & sFN
    
    'string to use for the recording
    sStr = "This is a short test string to be spoken in a user's wave file."
    
    'make voice wav file from string
    StringToWavFile sStr, sFP

End Sub

Function StringToWavFile(sIn As String, sPath As String) As Boolean
    'makes a spoken wav file from parameter text string
    'sPath parameter needs full path and file name to new wav file
    'If wave file does not initially exist it will be made
    'If wave file does initially exist it will be overwritten
    'Needs reference set to Microsoft Speech Object Library
    
    Dim fs As New SpFileStream
    Dim Voice As New SpVoice

    'set the audio format
    fs.Format.Type = SAFT22kHz16BitMono

    'create wav file for writing without events
    fs.Open sPath, SSFMCreateForWrite, False
 
    'Set wav file stream as output for Voice object
    Set Voice.AudioOutputStream = fs

    'send output to default wav file "SimpTTS.wav" and wait till done
    Voice.Speak sIn, SVSFDefault

    'Close file
    fs.Close

    'wait
    Voice.WaitUntilDone (6000)

    'release object variables
    Set fs = Nothing
    Set Voice.AudioOutputStream = Nothing

    'transfers
    StringToWavFile = True

End Function

See Also[edit | edit source]

External Links[edit | edit source]


Read Aloud Strings and Text

Summary[edit | edit source]

This page contains Excel VBA code to read out the contents of strings; that is, text held in a string variable. It can be adapted for use elsewhere in MS Office.

Code Notes[edit | edit source]

Place the entire code listing into a Standard Module and save the file with an xlsm suffix. Run the various subs to see how the code works.

The VBA Code[edit | edit source]

Sub BasicExcelSpeech()
 'Speaks the supplied string text in a default Excel voice
 'Default voice is changed via Windows Control Panel
 
 'Named Parameters of Speak():
 'Text: the text to read (Required)
 'SpeakAsync:=0, waits until done, or with 1, code runs during play (Optional)
 'SpeakXML:=0 , normal setting, or with 1, to ignore xml tags (Optional)
 'Purge:=0 , normal play, or with 1, clears the present play (Optional)
  
 Application.Speech.Speak Text:="Hello", SpeakAsync:=0, SpeakXML:=0, Purge:=0
 
End Sub

Sub testSpeakEachDigit()
   
    SpeakEachDigit "0123456789"
    
End Sub

Function SpeakEachDigit(sIn As String) As Boolean
    'non API method
    'uses excel's speak function to read a string, chara by chara
    'one character at a time
    
    Dim n As Long, m As Long, sS As String
    
    Application.EnableSound = True
    For n = 1 To Len(sIn)
        DoEvents
        sS = Mid(sIn, n, 1) 'take one character
        Application.Speech.Speak sS, 0, 0, 0
    Next n
    
    SpeakEachDigit = True

End Function

Sub testSetupSpeechVoice()
    'Run this to test SetupSpeechVoice()
    
    Dim sTxt As String, nVoc As Integer, nSpd As Integer, nVol As Integer
    
    sTxt = "The quick brown fox jumps over the lazy dog 1234567890 times."
    nVoc = 1        'chosen voice 0 or 1
    nSpd = 0        'speed of reading -10 to +10
    nVol = 100      'volume level 0 to 100

    SetupSpeechVoice sTxt, nVoc, nSpd, nVol
    
End Sub

Function SetupSpeechVoice(sText As String, Optional ByVal nVoices As Integer, _
                          Optional ByVal nRate As Integer, _
                          Optional ByVal nLoudness As Integer) As Boolean
    'Selects voice using an index, rate of speech -10 to +10,
    'and volume 0-100 for Speech.Speak()
    'Needs a VBA editor reference to Microsoft Speech Object Library
            
    Dim voc As SpeechLib.SpVoice
    
    Set voc = New SpVoice
    
    'avoid wrong choice of voice
    If nVoices > voc.GetVoices.Count - 1 Or nVoices < 0 Then
        MsgBox "Voice integer is out of range"
        Exit Function
    End If
    
    With voc
        Set .Voice = .GetVoices.Item(nVoices)
        .Rate = nRate
        .Volume = nLoudness
        .Speak sText
    End With

    SetupSpeechVoice = True

End Function

Sub ListAvailableVoices()
    'run this to know the id of the available voices
    'Needs a VBA editor reference to Microsoft Speech Object Library
    
    Dim n As Integer, sAccum As String
    Dim voc As SpeechLib.SpVoice
    
    Set voc = New SpVoice
        For n = 0 To voc.GetVoices.Count - 1
            Set voc.Voice = voc.GetVoices.Item(n)
            sAccum = sAccum & " " & n & " - " & voc.Voice.GetDescription & vbCrLf
            voc.Speak "My voice index number is " & CStr(n)
        Next n
        MsgBox sAccum

End Sub


Get Array Data Stats

Summary[edit | edit source]

This VBA code module is intended for MS Excel, since it prints a basic set of statistics onto the worksheet. It assumes that there is well behaved numerical data in a 1D array as an input. A frequency distribution is produced and associated statistics for the set.

Notes on the code[edit | edit source]

  • Copy the entire code listing into an Excel Standard module, save it, then run the top procedure.

VBA Code MOdule[edit | edit source]

Option Explicit
Option Base 1 'important

Private Sub testMakeBinsAndStatsFromArray()
    'Run this to test making of frequency
    'distribution and stats from arrays
    'THIS SUB CLEARS AND WRITES TO SHEET1
    
    Dim vArr As Variant, vBins As Variant
    
    'load a typical 1D data array
    vArr = Array(0, 0.125, 1, 5, 5, 23, 5.1, 5, 10, 10.05, 15, 15.01, 7.3, 16, 15, 0, 3)
    
    'load a typical 1D interval array
    'numbers are upper-limit-inclusive,
    'from previous-limit-exclusive
    vBins = Array(5, 10, 15, 20)
    
    BinStatsOfArrayData vArr, vBins, "Test"

    'report end
    MsgBox "Display done."

End Sub

Private Sub BinStatsOfArrayData(vI As Variant, vB As Variant, Optional sLabel As String = "")
    'Gets the basic stats for a 1D array of numbers.
    'Bin width is provided by an array in vB.
    'Results to the worksheet. Displays frequency
    'distribution, average, median, mode, minimum,
    'maximum, standard deviation, and variance.
    'THIS SUB CLEARS AND WRITES TO SHEET1
    
    Dim vR As Variant, vD As Variant
    Dim n As Long, bOK As Boolean
    Dim LB As Long, UB As Long, LBI As Long, UBI As Long
    
    LBI = LBound(vI, 1): UBI = UBound(vI, 1)
    
    bOK = FreqDist(vI, vB, vR)
    
    LB = LBound(vR, 1): UB = UBound(vR, 1)
    ReDim vD(LB To UB + 12, 1 To 3)
    
    If bOK Then 'load a display array
        'set labels and headings
        vD(1, 1) = sLabel: vD(1, 2) = "Value": vD(1, 3) = "Quantity"
        
        'frequency distribution display
        For n = LB To UB
            If n = LB Then                'first bin
                vD(n + 2, 2) = "<=" & vB(n)                      'bin size
                vD(n + 2, 3) = vR(n, 1)                           'quantity
            ElseIf n > LB And n < UB Then 'middle bins
                vD(n + 2, 2) = ">" & vB(n - 1) & " and <=" & vB(n) 'bin size
                vD(n + 2, 3) = vR(n, 1)                           'quantity
            ElseIf n = UB Then            'last bin
                vD(n + 2, 2) = ">" & vB(n - 1)                    'bin size
                vD(n + 2, 3) = vR(n, 1)                           'quantity
            End If
            vD(n + 2, 1) = "Bin # " & n 'headings
        Next n
        'get various other stats estimates for display
        On Error Resume Next 'avoids Mode() error when no value stands out
        With Application.WorksheetFunction
            vD(UB + 4, 1) = "Average": vD(UB + 4, 3) = Format(.Average(vI), "#0.000")
            vD(UB + 5, 1) = "Median": vD(UB + 5, 3) = .Median(vI)
            vD(UB + 6, 1) = "Mode": vD(UB + 6, 3) = .Mode(vI)
            vD(UB + 7, 1) = "Minimum": vD(UB + 7, 3) = .Min(vI)
            vD(UB + 8, 1) = "Maximum": vD(UB + 8, 3) = .Max(vI)
            vD(UB + 9, 1) = "Std.Deviation": vD(UB + 9, 3) = Format(.StDevP(vI), "#0.000")
            vD(UB + 10, 1) = "SD/Average % (CV)": vD(UB + 10, 3) = Format(.StDevP(vI) * 100 / .Average(vI), "#0.000")
            vD(UB + 11, 1) = "Variance": vD(UB + 11, 3) = Format(.VarP(vI), "#0.000")
            vD(UB + 12, 1) = "No. of Samples": vD(UB + 12, 3) = UBound(vI) - LBound(vI) + 1
        End With
        Err.Clear
    Else
        MsgBox "Problems getting bin count - closing"
        Exit Sub
    End If
    
    'output to sheet
    ClearWorksheet "Sheet1", 3        'clear both contents and formats of the worksheet
    Array2DToSheet vD, "Sheet1", 3, 3 'transfer whole array to sheet with top left at row3, col3
    FormatCells "Sheet1"              'apply font and autofit formats to all cells of the worksheet

End Sub

Private Function FreqDist(vData As Variant, vBounds As Variant, vRet As Variant) As Boolean
    'Gets the frequency distribution for data values in vData
    'Returns in vRet based on bin range data in vBounds.
        
    Dim vFD As Variant
    Dim LBD As Long, UBD As Long, LBB As Long, UBB As Long
        
    'get work array bounds
    LBD = LBound(vData): UBD = UBound(vData)     '1D
    LBB = LBound(vBounds): UBB = UBound(vBounds) '1D
    
    ReDim vRet(LBB To UBB + 1) 'one more than bounds
    
    With Application.WorksheetFunction
        'always returns as one-based array!
        vRet = .Frequency(vData, vBounds)
    End With
    
     FreqDist = True

End Function

Private Sub ClearWorksheet(ByVal sSheet As String, Optional ByVal nOpt As Integer = 1)
   'clears worksheet contents, formats, or both
   'but does not remove charts from the worksheet
   'nOpt options: contents=1, formats=2, all=3
      
   Dim oWSht As Worksheet
   Set oWSht = ThisWorkbook.Worksheets(sSheet)
   oWSht.Activate
   
   With oWSht.Cells
    Select Case nOpt
        Case 1 'contents only
            .ClearContents
        Case 2 'formats only
            .ClearFormats
        Case 3 'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearWorksheet - closing"
        Exit Sub
    End Select
   End With
   
   oWSht.Cells(1, 1).Select

End Sub

Private Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of input 2D array to specified worksheet positions
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nRows As Long, nCols As Long
    Dim nNewEndC As Long, nNewEndR As Long
    
    'get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    'get the pre-shift end points
    nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
    nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
    
    'modify end point for parameter starting values
    nNewEndR = nRows + nStartRow - 1
    nNewEndC = nCols + nStartCol - 1
       
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
    
    'transfer the array contents to the sheet range
    rTarget.Value = vIn

End Sub

Private Sub FormatCells(sSht As String)
    ' Applies certain formats to all cells
    ' of the named parameter worksheet
    
    Dim oSht As Worksheet
    
    Set oSht = ThisWorkbook.Worksheets(sSht)
    oSht.Activate
    
    'format all cells of the worksheet
    oSht.Cells.Select
    With Selection
        .Font.Name = "Consolas" 'mono
        .Font.Size = 20
        .Columns.AutoFit
        .Rows.AutoFit
        .HorizontalAlignment = xlLeft 'xlRight 'xlCenter
        .VerticalAlignment = xlBottom 'xlCenter 'xlTop
    End With
    oSht.Range("A1").Select

End Sub

See Also[edit | edit source]


Discrete Data Bin Stats

Summary[edit | edit source]

This code module is intended for MS Excel, since it writes a set of statistics to the worksheet. It assumes that there is discrete data in a 1D array, either string or numeric. A set of statistics is printed, not for the raw data on the array, but for the bin-count of discrete values found on it. It includes a listing of the bin counts and other statistics. For example, if the array contained only elements with a one or a zero value, the results would list the overall counts of each, and produce other statistics.

Notes on the code[edit | edit source]

  • Copy the entire code listing into an Excel Standard module, save it, then run the top procedure.

VBA Code Module[edit | edit source]

Option Explicit
Option Base 1

Private Sub testCountUniqueArrayValues()
    'Run this to count unique values,
    'string or numeric, in an array.
    'THIS SUB CLEARS AND WRITES TO SHEET1
    
    Dim vArr As Variant, nT As Long
    
    'load a typical 1D data array with test data
    vArr = Array("and", "AND", "And", 7, "C", 5, 8, 3, 5, 6, 7.6, "D", "B", "A", "C", "D")
    
    'pass array to the proc with label for the display
    CountUniqueArrayValues vArr, 2, 2, "Test Set 1:"

    'report end
    MsgBox "Display done."

End Sub

Private Sub CountUniqueArrayValues(vI As Variant, Optional nRow As Long = 1, _
                                   Optional nCol As Long = 1, Optional sLabel As String = "")
    'Counts instances of unique values in vI. Generates various stats
    'for the bin quantities of each, rather than the array of values themselves.
    'THIS SUB CLEARS AND WRITES TO SHEET1
    
    Dim vRV As Variant, vRQ As Variant, vDS As Variant
    Dim LB As Long, UB As Long, vDB As Variant
    Dim n As Long, bOK As Boolean
    
    'make bins and count contents
    bOK = DiscreteItemsCount(vI, vRV, vRQ)
    
    LB = LBound(vRV, 1): UB = UBound(vRV, 1)
    ReDim vDS(1 To 12, 1 To 3)
    ReDim vDB(LB To UB + 2, 1 To 3)
    
    If bOK Then 'load bins and stats arrays
        vDB(1, 1) = sLabel: vDB(1, 2) = "Value": vDB(1, 3) = "Quantity"
        For n = LB To UB
             vDB(n + 2, 1) = "Bin # " & n 'headings
             vDB(n + 2, 2) = vRV(n)      'value
             vDB(n + 2, 3) = vRQ(n)      'quantity
        Next n
        
        On Error Resume Next 'avoids Mode() error when no value stands out
        With Application.WorksheetFunction
            vDS(1, 1) = sLabel: vDS(1, 2) = "": vDS(1, 3) = "Quantity"
            vDS(3, 1) = "Average": vDS(3, 3) = Format(.Average(vRQ), "#0.000")
            vDS(4, 1) = "Median": vDS(4, 3) = .Median(vRQ)
            vDS(5, 1) = "Mode": vDS(5, 3) = .Mode(vRQ)
            vDS(6, 1) = "Minimum": vDS(6, 3) = .Min(vRQ)
            vDS(7, 1) = "Maximum": vDS(7, 3) = .Max(vRQ)
            vDS(8, 1) = "Std.Deviation": vDS(8, 3) = Format(.StDevP(vRQ), "#0.000")
            vDS(9, 1) = "StDev/Av %": vDS(9, 3) = Format(.StDevP(vRQ) * 100 / .Average(vRQ), "#0.000")
            vDS(10, 1) = "Variance": vDS(10, 3) = Format(.VarP(vRQ), "#0.000")
            vDS(11, 1) = "No.Unique Values": vDS(11, 3) = UBound(vRQ) - LBound(vRQ) + 1
            vDS(12, 1) = "No.Samples": vDS(12, 3) = UBound(vI) - LBound(vI) + 1
        End With
        Err.Clear
    Else
        MsgBox "Problems getting bin count - closing"
        Exit Sub
    End If
    
    'output to sheet
    ClearWorksheet "Sheet1", 3                        'clear both contents and formats of the worksheet
    Array2DToSheet vDS, "Sheet1", nRow, nCol          'transfer stats panel to sheet with top left at row3, col3
    If UB <= 65536 Then 'rows limit for excel 2003
        Array2DToSheet vDB, "Sheet1", nRow + 13, nCol 'transfer bins panel to sheet with top left below stats
    Else
        MsgBox "To many bins for sheet -closing"
        Exit Sub
    End If
    FormatCells "Sheet1"  'apply font and autofit formats to all cells of the worksheet

End Sub

Private Function DiscreteItemsCount(vIn As Variant, vRetV As Variant, vRetQ As Variant) As Boolean
    'Counts number of repeats of element values found in vIn
    'Returns with one column for each unitque value and quantity found.
    'Returns as 2D vRet, unsorted; row1=input value, row2=item count.

    Dim vA As Variant, vTS As Variant, vTB As Variant
    Dim s As Long, b As Long, n As Long, bFound As Boolean
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    Dim LBS As Long, UBS As Long
    
    'dimension 2D work array
    ReDim vA(1 To 2, 1 To 1)
    
    'get source 1D array bounds
    LBS = LBound(vIn): UBS = UBound(vIn)
    
    'get work array bounds
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
    
    'intitial values
    s = LBS
    b = 0
    vA(2, 1) = 0
    
    Do 'step through store
        DoEvents
        'get source element value
        vTS = vIn(s)
        'check bins
        Do
            DoEvents
            b = b + 1
            'get bin element value
            vTB = vA(1, b)
            If vTS = vTB Then 'found in bins
                vA(2, b) = CLng(vA(2, b)) + 1 'update bin
                bFound = True
            End If
        Loop Until b >= UB2 Or bFound = True
        
        If bFound = False Then 'no such bin exists yet
            'not found in bins
            If vA(2, UB2) <> 0 Then 'first element been used
                ReDim Preserve vA(LB1 To UB1, LB2 To UB2 + 1)
                UB2 = UBound(vA, 2)
            End If
            'update new bin
            vA(1, UB2) = vTS
            vA(2, UB2) = 1
            bFound = True
        End If
        
        'reset loop variables
        bFound = False
        b = 0
        s = s + 1
    Loop Until s > UBS

    'transfers -need to be separate for other uses
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
    ReDim vRetV(LB2 To UB2) 'contains values
    ReDim vRetQ(LB2 To UB2) 'contains quantities
    
    For n = LB2 To UB2
        vRetV(n) = vA(1, n)
        vRetQ(n) = vA(2, n)
    Next n
        
    For n = LB2 To UB2
        Debug.Print vRetV(n) & vbTab & vRetQ(n)
    Next n
        Debug.Print vbCrLf
   
   DiscreteItemsCount = True

End Function

Private Sub ClearWorksheet(ByVal sSheet As String, Optional ByVal nOpt As Integer = 1)
   'clears worksheet contents, formats, or both
   'but does not remove charts from the worksheet
   'nOpt options: contents=1, formats=2, all=3
      
   Dim oWSht As Worksheet
   Set oWSht = ThisWorkbook.Worksheets(sSheet)
   oWSht.Activate
   
   With oWSht.Cells
    Select Case nOpt
        Case 1 'contents only
            .ClearContents
        Case 2 'formats only
            .ClearFormats
        Case 3 'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearWorksheet - closing"
        Exit Sub
    End Select
   End With
   
   oWSht.Cells(1, 1).Select

End Sub

Private Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of input 2D array to specified worksheet positions
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nRows As Long, nCols As Long
    Dim nNewEndC As Long, nNewEndR As Long
    
    'get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    'get the pre-shift end points
    nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
    nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
    
    'modify end point for parameter starting values
    nNewEndR = nRows + nStartRow - 1
    nNewEndC = nCols + nStartCol - 1
       
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
    
    'transfer the array contents to the sheet range
    rTarget.Value = vIn

End Sub

Private Sub FormatCells(sSht As String)
    ' Applies certain formats to all cells
    ' of the named parameter worksheet
    
    Dim oSht As Worksheet
    
    Set oSht = ThisWorkbook.Worksheets(sSht)
    oSht.Activate
    
    'format all cells of the worksheet
    oSht.Cells.Select
    With Selection
        .Font.Name = "Consolas" 'mono
        .Font.Size = 20
        .Columns.AutoFit
        .Rows.AutoFit
        .HorizontalAlignment = xlLeft 'xlRight 'xlCenter
        .VerticalAlignment = xlBottom 'xlCenter 'xlTop
    End With
    oSht.Range("A1").Select

End Sub


See Also[edit | edit source]


The Knuth String Shuffle

Summary[edit | edit source]

  • This code module includes both a Fisher-Yates character shuffling routine for strings, and a Durstenfeld-Knuth routine to shuffle one-dimensional arrays.
    • The procedure FisherYatesStrShuffle() shuffles characters of a single string. This is limited to shifting single characters around within one string.
    • Procedure KnuthArrShuffle() sorts the elements of a one-dimensional array. The procedure is limited only by what can be stored in array elements.
  • The two methods are pseudo-random and bias-free. Elsewhere, the use of a random generator does not necessarily guarantee that the results will be free from bias.
  • The code can work in any of the MS Office applications that support VBA.

Code Notes[edit | edit source]

  • The Fisher-Yates shuffle applies a pseudo random selection method. It is described here for characters in a string but a related method, the Durstenfeld-Knuth method is preferred for arrays.
    • Taking each element of a string in sequence for repositioning leaves one end of the result string badly biased. The Knuth algorithm instead proposes a random position within the string. The element at that position is then accumulated into the output and removed from the original. Subsequent selections are made in the same way from the ever shortened string.
    • Note that there is still the possibility of a given character being unmoved in the process, but only within expectation.
    • Set the number of strings required with variable Cycles in the top procedure. The Immediate Window has proved the best place for display and copying.
    • It should be pointed out that any attempt to avoid the unmoved elements, will not only change the random nature of the shuffle but prevent the use of other than non-repeat strings. That is to say strings with repeated characters could not then be shuffled.
  • The Durstenfeld-Knuth method for arrays differs only slightly from that of the Fisher-Yates implementation.
    • To reduce processing, and no doubt to overcome the burden of removing an element from the middle of an array during shortening, the algorithm instead overwrites the element selected for output with the last element. In this VBA implementation the array is then conveniently shortened by one element with Redim Preserve.
  • See Fisher Yates Shuffle for a good description of both methods.

The VBA Code Module[edit | edit source]

Copy all of the code below into say, an MS Excel standard module, save the workbook as an xlsm file type, and run either of the test procedures to test the requisite code. Be sure to open the Immediate Window for output.

Option Explicit

Private Sub testFisherYatesStrShuffle()
    'run this to test the string shuffle
    
    Dim bOK As Boolean, sStr As String, sR As String
    Dim sOut As String, n As Long, Cycles As Long
    
    'set number of shuffled versions needed
    Cycles = 1
    
    'test string
    sStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"

    For n = 1 To Cycles
        bOK = FisherYatesStrShuffle(sStr, sR)
        sOut = sR
        
        If bOK = False Then
           MsgBox "Problems in shuffle"
           Exit Sub
        End If
        
        'output to message box and immediate window
        'MsgBox "Before : " & sStr & vbCrLf & _
               "After    : " & sR
        Debug.Print "Before : " & sStr
        Debug.Print "After  : " & sOut & vbCrLf
    Next n
    
End Sub

Private Function FisherYatesStrShuffle(ByVal sIn As String, sOut As String) As Boolean
    'Performs a naive Fisher-Yates shuffle on the input string.
    'Returns result in sOut. Pseudo random character sequencing.
    
    'Note: Some or all elements could occupy their original positions,
    'but only in accordance with expectation based on the random generator.
    'This can be seen best for very short character strings, like "ABC".
            
    Dim sL As String, sR As String, sT1 As String, sT2 As String, sMod As String
    Dim sAcc As String, i As Long, j As Long, nL As Long, n As Long
        
    'check input string
    If sIn = "" Or Len(sIn) < 2 Then
       MsgBox "At least 2 characters needed - closing"
       Exit Function
    End If
        
    'initial assignments
    nL = Len(sIn)
    sMod = sIn
    
    Randomize
    For i = 1 To Len(sIn)
        'first get a random number
        j = Int((nL - 1 + 1) * Rnd + 1)
            
        'find string value of jth element
        sT1 = Mid$(sMod, j, 1)
        DoEvents 'allow break
                
        'accumulate jth element
        sAcc = sAcc & sT1
        
        'remove current character
        sL = Left$(sMod, j - 1)
        sR = Right$(sMod, nL - j)
        sMod = sL & sR
        
        'new string length
        nL = Len(sMod)
        DoEvents 'allow break
    Next i

    'transfer
    sOut = sAcc
    
    FisherYatesStrShuffle = True

End Function

Private Sub testKnuthArrShuffle()
    'run this to test the array shuffle
    
    Dim bOK As Boolean, sStr As String, sOut As String
    Dim Cycles As Long, n As Long, bF As Boolean
    Dim vS As Variant, vA As Variant, vB As Variant
           
    'define a typical array for shuffling
    vS = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
               "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
               "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
    
    'set number of shuffled versions needed
    Cycles = 1
    
    For n = 1 To Cycles
    
        'shuffle array
        bOK = KnuthArrShuffle(vS, vA)
                
        If bOK = False Then
           MsgBox "Problems in array shuffle"
           Exit Sub
        End If
            
        'arrays to strings for display
        sStr = Arr1DToStr2(vS)
        sOut = Arr1DToStr2(vA)
        
        'display
    '    MsgBox "Before : " & sStr & vbCrLf & _
    '           "After    : " & sOut
        Debug.Print "Before : " & sStr
        Debug.Print "After  : " & sOut & vbCrLf
           
        'return to an array in vB if needed
        bF = StrTo1DArr2(sOut, vB)

    Next n

End Sub

Private Function KnuthArrShuffle(vIn As Variant, vR As Variant) As Boolean
    ' Performs a modified Knuth random shuffle on the elements of the input array.
    ' The original by Fisher-Yates, was modified for computers by Durstenfeld
    ' then popularised by Knuth. Returns result in vR with vIn unchanged.
       
    'Note: Some or all elements COULD occupy their original positions,
    'but only in accordance with expectation based on the random generator.
    'This is best seen for small arrays, say with only 3 elements or so.
        
    Dim vW As Variant
    Dim LB As Long, UB As Long, nL As Long
    Dim i As Long, j As Long
    
    'initial assignments
    LB = LBound(vIn): UB = UBound(vIn)
    ReDim vR(LB To UB) 'return array
    ReDim vW(LB To UB) 'work array
    nL = UB - LB + 1   'length of input array
    vW = vIn 'transfer to a work array
            
    'working
    Randomize
    For i = LB To nL
        'first get a random number
        j = Int((UB - LB + 1) * Rnd + LB)
            
        'transfer jth of vW to ith of vR
        vR(i) = vW(j)
        
        'replace selection with current last of vW
        vW(j) = vW(UB)
        
        'remove last of vW by shortening array
        ReDim Preserve vW(LB To UB - 1)
        
        'get new UBound of shortened vW
        UB = UBound(vW)
        
        'exception; return if last chara
        If UB = LB Then
            vR(i + 1) = vW(UB)
            Exit For
        End If
                
        DoEvents 'allow breaks
    Next i
        
    KnuthArrShuffle = True

End Function
Function StrTo1DArr2(ByVal sIn As String, vRet As Variant, _
                    Optional ByVal bLB1 As Boolean = True) As Boolean
    ' Loads string characters into 1D array (vRet). One per element.
    ' Optional choice of lower bound. bLB1 = True for one-based (default),
    ' else bLB1 = False for zero-based. vRet dimensioned in proc.

    Dim nC As Long, sT As String
    Dim LB As Long, UB As Long
    
    If sIn = "" Then
        MsgBox "Empty string - closing"
        Exit Function
    End If
    
    'allocate array for chosen lower bound
    If bLB1 = True Then
        ReDim vRet(1 To Len(sIn))
    Else
        ReDim vRet(0 To Len(sIn) - 1)
    End If
    LB = LBound(vRet): UB = UBound(vRet)

    'load charas of string into array
    For nC = LB To UB
        If bLB1 = True Then
            sT = Mid$(sIn, nC, 1)
        Else
            sT = Mid$(sIn, nC + 1, 1)
        End If
        vRet(nC) = sT
    Next

    StrTo1DArr2 = True

End Function
    
Function Arr1DToStr2(vIn As Variant) As String
    ' Makes a single string from 1D array string elements.
    ' Works for any array bounds.
        
    Dim nC As Long, sT As String, sAccum As String
    Dim LB As Long, UB As Long
    
    LB = LBound(vIn): UB = UBound(vIn)

    'join characters of array into string
    For nC = LB To UB
        sT = vIn(nC)
        sAccum = sAccum & sT
    Next

    Arr1DToStr2 = sAccum

End Function

See Also[edit | edit source]

  • Fisher Yates Shuffle: A very clearly written article in Wikipedia, that explains worked examoles step by step.

External Links[edit | edit source]


Compare Shuffle Methods for Bias

Summary[edit | edit source]

This VBA code module shows how bias can affect a shuffle algorithm, even when a random generator is used. The module is intended for MS Excel and prints two statistics panels on the worksheet to show how the selected methods differ. The good version is the Knuth shuffle algorithm, and the other is one that makes methodical swaps, sometimes multiple swaps, throughout the length of the array.

Notes on the code[edit | edit source]

  • Copy the entire code listing into an Excel Standard module, save it, then run the top procedure.
  • The shuffle algorithms run for many cycles, (user set), and the bin count of discrete outcomes is presented in statistics. Notice that a very small number of elements, (3 or 4), has been used to keep the display and run time manageable. It may be of interest to know that the number of discrete outcome combinations is equal to the factorial of the number of elements. That is; using just six elements, say A,B,C,D,E,and F, would result in 6! = 120 discrete combinations, and a corresponding increase in the time to run.
  • In particular, it should be noted that a small coefficient of variation (CV) denotes a method that is close to random whereas one with a higher CV shows that there is bias in the method.
  • The method that uses multiple swaps is biased, whereas the Knuth method is not.

VBA Code Module[edit | edit source]

Option Explicit
Option Base 1

Private Sub RunShuffleBiasDemo()
    'Run this to compare the bias for shuffling
    'character arrays using two methods.
    'Note large sets are too time consuming,
    'since there are n! combinations.
    'THIS SUB CLEARS AND WRITES TO SHEET1
    
    Dim vArr As Variant, vRet As Variant
    Dim nT As Long, bOK As Boolean, vT As Variant
    Dim nCycles As Long, n As Long, sT As String
    
    'load a typical 1D data array with test data
    '3 elements makes 3! = 6 bins
    '4 elements needs 4! = 24 bins etc.
    vArr = Array("A", "B", "C")
    
    'set number of cycles for test
    'Typical time to complete 3 element test:
    '25 secs for 100000 cycles
    '225 secs for 1000000 cycles
    nCycles = 100000
    
        
    'dimension the collection array
    ReDim vT(1 To nCycles)
        
    'clear the worksheet
    ClearWorksheet "Sheet1", 3 'contents and formats
        
    'runs number of shuffle samples
    For n = 1 To nCycles
        'give way to commands-eg; break
        DoEvents
        
        'pass array to a random shuffling proc
        bOK = KnuthArrShuffle(vArr, vRet)
                
        'make a single string from array elements
        sT = Arr1DToStr(vRet)
        
        'save shuffle instance in an array
        vT(n) = sT
    Next n
       
    'pass array to the proc with label for the display
    CountUniqueArrayValues2 vT, 2, 2, "Test Set: Rnd Knuth"
    
    'run a number of shuffle samples
    For n = 1 To nCycles
        'give way to commands-eg; break
        DoEvents
        
        'pass array to a random shuffling proc
        bOK = BiasedMultiSwapArrShuffle(vArr, vRet)
        
        'make a single string from array elements
        sT = Arr1DToStr(vRet)
        
        'save shuffle instance in an array
        vT(n) = sT
    Next n
       
    'pass array to the proc with label for the display
    CountUniqueArrayValues2 vT, 2, 7, "Test Set: Rnd Biased?"

    'report end
    MsgBox "Display done."

End Sub

Private Sub CountUniqueArrayValues2(vI As Variant, Optional nRow As Long = 1, _
                                   Optional nCol As Long = 1, Optional sLabel As String = "")
    'Counts instances of data number values in vI. Generates various stats
    'for the bin quantities.
    'THIS SUB CLEARS AND WRITES TO SHEET1
    
    Dim vRV As Variant, vRQ As Variant, vDS As Variant
    Dim LB As Long, UB As Long, vDB As Variant
    Dim n As Long, bOK As Boolean
    
    'make bins and count contents
    bOK = DiscreteItemsCount(vI, vRV, vRQ)
    
    LB = LBound(vRV, 1): UB = UBound(vRV, 1)
    ReDim vDS(1 To 12, 1 To 3)
    ReDim vDB(LB To UB + 2, 1 To 3)
    
    If bOK Then 'load bins and stats arrays
        vDB(1, 1) = sLabel: vDB(1, 2) = "Value": vDB(1, 3) = "Quantity"
        For n = LB To UB
             DoEvents
             vDB(n + 2, 1) = "Bin # " & n 'headings
             vDB(n + 2, 2) = vRV(n)       'value
             vDB(n + 2, 3) = vRQ(n)       'quantity
        Next n
        
        On Error Resume Next 'avoids Mode() error when no value stands out
        With Application.WorksheetFunction
            vDS(1, 1) = sLabel: vDS(1, 2) = "": vDS(1, 3) = "Quantity"
            vDS(3, 1) = "Average": vDS(3, 3) = Format(.Average(vRQ), "#0.000")
            vDS(4, 1) = "Median": vDS(4, 3) = .Median(vRQ)
            vDS(5, 1) = "Mode": vDS(5, 3) = .Mode(vRQ)
            vDS(6, 1) = "Minimum": vDS(6, 3) = .Min(vRQ)
            vDS(7, 1) = "Maximum": vDS(7, 3) = .Max(vRQ)
            vDS(8, 1) = "Std.Deviation": vDS(8, 3) = Format(.StDevP(vRQ), "#0.000")
            vDS(9, 1) = "StDev/Av %": vDS(9, 3) = Format(.StDevP(vRQ) * 100 / .Average(vRQ), "#0.000")
            vDS(10, 1) = "Variance": vDS(10, 3) = Format(.VarP(vRQ), "#0.000")
            vDS(11, 1) = "No.Unique Values": vDS(11, 3) = UBound(vRQ) - LBound(vRQ) + 1
            vDS(12, 1) = "No.Samples": vDS(12, 3) = UBound(vI) - LBound(vI) + 1
        End With
        Err.Clear
    Else
        MsgBox "Problems getting bin count - closing"
        Exit Sub
    End If
    
    'output to sheet
    'ClearWorksheet "Sheet1", 3                    'clear both contents and formats of the worksheet
    Array2DToSheet vDS, "Sheet1", nRow, nCol      'transfer stats panel to sheet with top left at row2, col2
    Array2DToSheet vDB, "Sheet1", nRow + 13, nCol 'transfer bins panel to sheet with top left below stats
    FormatCells "Sheet1"                          'apply font and autofit formats to all cells of the worksheet

End Sub

Private Function DiscreteItemsCount(vIn As Variant, vRetV As Variant, vRetQ As Variant) As Boolean
    'Counts number of repeats of element values found in vIn
    'Returns with one column for each unitque value and quantity found.
    'Returns as 2D vRet, unsorted; row1=input value, row2=item count.

    Dim vA As Variant, vTS As Variant, vTB As Variant
    Dim s As Long, b As Long, n As Long, bFound As Boolean
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    Dim LBS As Long, UBS As Long
    
    'dimension 2D work array
    ReDim vA(1 To 2, 1 To 1)
    
    'get source 1D array bounds
    LBS = LBound(vIn): UBS = UBound(vIn)
    
    'get work array bounds
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
    
    'intitial values
    s = LBS
    b = 0
    vA(2, 1) = 0
    
    Do 'step through store
        DoEvents
        'get source element value
        vTS = vIn(s)
        'check bins
        Do
            DoEvents
            b = b + 1
            'get bin element value
            vTB = vA(1, b)
            If vTS = vTB Then 'found in bins
                vA(2, b) = CLng(vA(2, b)) + 1 'update bin
                bFound = True
            End If
        Loop Until b >= UB2 Or bFound = True
        
        If bFound = False Then 'no such bin exists yet
            'not found in bins
            If vA(2, UB2) <> 0 Then 'first element been used
                ReDim Preserve vA(LB1 To UB1, LB2 To UB2 + 1)
                UB2 = UBound(vA, 2)
            End If
            'update new bin
            vA(1, UB2) = vTS
            vA(2, UB2) = 1
            bFound = True
        End If
        
        'reset loop variables
        bFound = False
        b = 0
        s = s + 1
    Loop Until s > UBS

    'transfers -need to be separate for other uses
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
    ReDim vRetV(LB2 To UB2) 'contains values
    ReDim vRetQ(LB2 To UB2) 'contains quantities
    
    For n = LB2 To UB2
        vRetV(n) = vA(1, n)
        vRetQ(n) = vA(2, n)
    Next n
        
    For n = LB2 To UB2
        Debug.Print vRetV(n) & vbTab & vRetQ(n)
    Next n
        Debug.Print vbCrLf
   
   DiscreteItemsCount = True

End Function

Private Sub ClearWorksheet(ByVal sSheet As String, Optional ByVal nOpt As Integer = 1)
   'clears worksheet contents, formats, or both
   'but does not remove charts from the worksheet
   'nOpt options: contents=1, formats=2, all=3
      
   Dim oWSht As Worksheet
   Set oWSht = ThisWorkbook.Worksheets(sSheet)
   oWSht.Activate
   
   With oWSht.Cells
    Select Case nOpt
        Case 1 'contents only
            .ClearContents
        Case 2 'formats only
            .ClearFormats
        Case 3 'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearWorksheet - closing"
        Exit Sub
    End Select
   End With
   
   oWSht.Cells(1, 1).Select

End Sub

Private Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of input 2D array to specified worksheet positions
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nRows As Long, nCols As Long
    Dim nNewEndC As Long, nNewEndR As Long
    
    'get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    'get the pre-shift end points
    nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
    nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
    
    'modify end point for parameter starting values
    nNewEndR = nRows + nStartRow - 1
    nNewEndC = nCols + nStartCol - 1
       
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
    
    'transfer the array contents to the sheet range
    rTarget.Value = vIn

End Sub

Private Sub FormatCells(sSht As String)
    ' Applies certain formats to all cells
    ' of the named parameter worksheet
    
    Dim oSht As Worksheet
    
    Set oSht = ThisWorkbook.Worksheets(sSht)
    oSht.Activate
    
    'format all cells of the worksheet
    oSht.Cells.Select
    With Selection
        .Font.Name = "Consolas" 'mono
        .Font.Size = 14
        .Columns.AutoFit
        .Rows.AutoFit
        .HorizontalAlignment = xlLeft 'xlRight 'xlCenter
        .VerticalAlignment = xlBottom 'xlCenter 'xlTop
    End With
    oSht.Range("A1").Select

End Sub

Private Function KnuthArrShuffle(vIn As Variant, vR As Variant) As Boolean
    ' Performs a modified Knuth random shuffle on the elements of the input array.
    ' The original by Fisher-Yates, was modified for computers by Durstenfeld
    ' then popularised by Knuth. Returns result in vR with vIn unchanged.
       
    'Note: Some or all elements COULD occupy their original positions,
    'but only in accordance with expectation based on the random generator.
    'This is best seen for small arrays, say with only 3 elements or so.
        
    Dim vW As Variant
    Dim LB As Long, UB As Long, nL As Long
    Dim i As Long, j As Long
    
    'initial assignments
    LB = LBound(vIn): UB = UBound(vIn)
    ReDim vR(LB To UB) 'return array
    ReDim vW(LB To UB) 'work array
    nL = UB - LB + 1   'length of input array
    vW = vIn 'transfer to a work array
            
    'working
    Randomize
    For i = LB To nL
        'first get a random number
        j = Int((UB - LB + 1) * Rnd + LB)
            
        'transfer jth of vW to ith of vR
        vR(i) = vW(j)
        
        'replace selection with current last of vW
        vW(j) = vW(UB)
        
        'remove last of vW by shortening array
        ReDim Preserve vW(LB To UB - 1)
        
        'get new UBound of shortened vW
        UB = UBound(vW)
        
        'exception; return if last chara
        If UB = LB Then
            vR(i + 1) = vW(UB)
            Exit For
        End If
                
        DoEvents 'allow breaks
    Next i
        
    KnuthArrShuffle = True

End Function

Private Function BiasedMultiSwapArrShuffle(vIn As Variant, Optional vRet As Variant) As Boolean
    'Performs a random shuffle on input array strings.
    'Input parameter is a single array.  Returns in single vRet
    'if provided, else in vIn modified.  Multiple shuffles applied.
    'Displays more bias than the Knuth method.
    
    Dim vR As Variant
    Dim sT As String, sTJ As String, sTS As String, nC As Long
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    Dim i As Integer, j As Long, bSUsed As Boolean, bRUsed As Boolean

    'get dimensions of vIn
    LB1 = LBound(vIn): UB1 = UBound(vIn)

    'dimension a work array
    ReDim vR(LB1 To UB1)

    'load local array
    For i = LB1 To UB1
        DoEvents
        vR(i) = vIn(i)
    Next i

    'get dimensions of vR
    LB2 = LBound(vR): UB2 = UBound(vR)

    'randomize the rnd generator
    Randomize

    For i = LB2 To UB2
        
        DoEvents
        'get rnd number
        j = Int((UB2 - LB2 + 1) * Rnd + LB2)

        'exchange elements
        sT = vR(i) 'swap
        vR(i) = vR(j)
        vR(j) = sT
    Next i

    'transfers
    If Not IsMissing(vRet) Then
        ReDim vRet(LB2 To UB2)
        For i = LB2 To UB2
            DoEvents
            vRet(i) = vR(i)
        Next i
    Else
        For i = LB2 To UB2
            DoEvents
            vIn(i) = vR(i)
        Next i
    End If

    'return status
    BiasedMultiSwapArrShuffle = True

End Function

Private Function Arr1DToStr(vIn As Variant) As String
    ' Makes a single string from 1D array string elements.
    ' Works for any array bounds.

    Dim nC As Long, sT As String, sAccum As String
    Dim LB As Long, UB As Long

    LB = LBound(vIn): UB = UBound(vIn)

    'join characters of array into string
    For nC = LB To UB
        DoEvents
        sT = vIn(nC)
        sAccum = sAccum & sT
    Next

    Arr1DToStr = sAccum

End Function

See Also[edit | edit source]


Backup Text Boxes on Close

Summary[edit | edit source]

This VBA code is written for Microsoft Excel but is easily adapted to other applications in the MS Office set. It saves all of the text from a user form's text boxes in a log file whenever the form is closed. Then later, on re-opening the form, or at any other time, the user can fill the boxes with the most recent saved text.

The VBA Code[edit | edit source]

  • The code needs a user form called Userform1, two text boxes, TextBox1 and TextBox2, and a command button called CommandButton1. Set the UserForm1 property ShowModal to false for convenient study. Copy the code below into the three respective modules and save the workbook with an xlsm file suffix.
  • Any code that is found in text boxes will be saved when the user form closes. This includes inadvertent closure of the user form or the deliberate closing of the workbook. It does not of course protect against the effect of power failures. The saving of data happens without intervention, so may need consideration if the storage of sensitive data is to be avoided.
  • The log file is called SavedText.txt, and will be found in the same folder as the workbook. If a log file of that name is not found, then it will be made by the code for use. The log file has only two fields, the text box name and the string contents found in it. The comma separator was avoided in favor of the less likely encountered string >Break<.
  • The saving function runs from the UserForm_QueryClose event. SaveTextBoxes() makes a log string in a userform controls loop, then exports the string via WriteToFile().
  • WriteToFile() makes a log file if it does not exist, but otherwise overwrites any text that it finds, so that only the most recently saved session will be found there. Users who employ the logging procedure elsewhere should note that an extra Cr and Lf are stored at the end of logged entries, and might need consideration.
  • RestoreTextBoxes() runs only by pressing CommandButton1, so the user chooses whether or not to insert text. GetAllFileText() imports all of the log file's contents at once with the file retaining contents until it is next overwritten. The string is split twice, once to break it into lines, that is, one for each text box record, and then again to break each record into its two fields for matching control names in the main transfer loop.

Code Changes[edit | edit source]

8 March 2019: Changed data separator from comma to other, in Standard Module

For the ThisWorkbook Module[edit | edit source]

'...............................................
' Notes: Code needs a user form named UserForm1,
' with two text boxes, TextBox1 and Textbox2,
' and a command button with name CommandButton1.
' Set UserForm1 property ShowModal to False 
'...............................................

Private Sub Workbook_Open()
    'Runs on opening the workbook
   
    Load UserForm1
    UserForm1.Show

End Sub

For the Userform1 Module[edit | edit source]

Private Sub CommandButton1_Click()
    ' Restores saved textbox text
    ' after reopening the user form
    
    ' restores textbox text from file
    RestoreTextBoxes
    
    'set insertion point to TextBox1
    With TextBox1
        .SelStart = Len(.Value) 'to end of text
        .SelLength = 0          'just insertion
        .SetFocus
    End With

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' Runs before closing the userform
    ' Used here to save textbox values in a log file

    SaveTextBoxes
    
End Sub

For the Standard Module[edit | edit source]

Option Explicit

Sub SaveTextBoxes()
    ' Saves values from user form text boxes to a log file
    ' Data is never lost while log file exists
    ' Runs in the UserForm_QueryClose() event at all times.
        
    Dim oForm As UserForm, oCont As Control, sStringOut As String
    Dim bCont As Boolean, sPath As String, sLogPath As String
    Dim sType As String
    
    Set oForm = UserForm1
    sPath = Application.ThisWorkbook.Path
    sLogPath = sPath & "\" & "SavedText.txt" 'log file address
    sType = "TextBox"
    
    'step through the form controls to find the textboxes
    For Each oCont In oForm.Controls
        If TypeName(oCont) = sType Then
            sStringOut = sStringOut & oCont.Name & ">Break<" & oCont.Value & vbCrLf
        End If
    Next oCont
    
    'remove tailend Cr and Lf
    sStringOut = Left$(sStringOut, Len(sStringOut) - 2)
    
    'send textbox string to the log file
    WriteToFile sStringOut, sLogPath
        
    'release object variables
    Set oForm = Nothing
    Set oCont = Nothing

End Sub

Function WriteToFile(ByVal sIn As String, ByVal sPath As String) As Boolean
    ' REPLACES all content of a text file with parameter string
    ' Makes the file if it does not exist
    ' Assumes that all formatting is already in sIn
    ' Note that this log file will add Cr and Lf to the stored string
    
    Dim Number As Integer
    
    Number = FreeFile 'Get a file number
    
    'write string to file
    Open sPath For Output As #Number
    Print #Number, sIn
    Close #Number

    WriteToFile = True
    
End Function

Sub RestoreTextBoxes()
    ' Restores saved values to user form text boxes.
    ' Data is never lost while log file exists.
    ' Runs when CommandButton1 is pressed
        
    Dim oCont As Control, oForm As UserForm
    Dim vA As Variant, vB As Variant, sRet As String
    Dim sPath As String, sLogPath As String, nC As Long
    
    Set oForm = UserForm1
    sPath = Application.ThisWorkbook.Path
    sLogPath = sPath & "\" & "SavedText.txt"
    
    'get text from the log file
    GetAllFileText sLogPath, sRet
    
    'remove the extra Cr and Lf added by the log file
    sRet = Left(sRet, Len(sRet) - 2)
    
    'step through controls to match up text
    vA = Split(sRet, vbCrLf)
    For nC = LBound(vA, 1) To UBound(vA, 1)
        'MsgBox Asc(vA(nC))
        vB = Split(vA(nC), ">Break<")
            For Each oCont In oForm.Controls
                If oCont.Name = vB(0) Then
                    oCont.Value = vB(1)
                End If
            Next oCont
    Next nC
   
    'release object variables
    Set oForm = Nothing
    Set oCont = Nothing

End Sub

Function GetAllFileText(ByVal sPath As String, sRet As String) As Boolean
    ' Returns entire log file text in sRet
    ' Note that this log file will add Cr and Lf to the original string
    
    Dim Number As Integer

    'get next file number
    Number = FreeFile

    'Open file
    Open sPath For Input As Number

    'get entire file content
    sRet = Input(LOF(Number), Number)
    
    'Close File
    Close Number

    'transfers
    GetAllFileText = True

End Function

See Also[edit | edit source]

External Links[edit | edit source]


Block Illegal Characters

Summary[edit | edit source]

This VBA example can be run in any of the commonly used Microsoft Office applications. The examples show how to exclude illegal characters from text boxes while the keys are being pressed. In each of the two examples, the insertion point simply remains where it was when an illegal character is entered; accepted characters appear in the usual way. Both examples make use of the TextBox_KeyPress event; then first accepting only integers and a few other characters, and the second only letters and some supporting characters.

The VBA Code[edit | edit source]

For the ThisWorkbook Module[edit | edit source]

'...............................................
' Notes: Code needs a user form named UserForm1,
' with two text boxes, TextBox1 and Textbox2,
' and a command button with name CommandButton1.
' Set UserForm1 property ShowModal to False 
'...............................................

Private Sub Workbook_Open()
    'Runs on opening the workbook
   
    Load UserForm1
    UserForm1.Show

End Sub

For the UserForm1 Module[edit | edit source]

  • Make sure that the ShowModal property of the user form is set to False, to allow normal code working and study with an open form.
  • Copy the code below into the UserForm1 module, and type text into the boxes to see the results.
  • Setting the parameter KeyAscii in code to the ASCI value of a non-printing character (eg: zero), prevents the display of the character that originated the event. Otherwise, KeyAscii is found to contain the ASCI value of the key that was pressed, and it is displayed.
  • The KeyAscii value can be changed to any asci value, and provided that it is a printing character, it will be displayed.
  • In each case code is added to restrict the permitted positions in the text. For example, a minus sign is valid only at the start of a number, and a hyphen is never expected at the start of a word.
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    'Block character input other than integers, minus signs, and periods
    'For example, to enter a number and decimal, eg; -4756.09
    
    Select Case KeyAscii
        'accept integers
        Case Asc("0") To Asc("9")
        Case Asc("-") ' unless one already exists or cursor not at start
            If InStr(1, Me.TextBox1.Text, "-") > 0 Or Me.TextBox1.SelStart > 0 Then
                KeyAscii = 0 'return a non-printing character
            End If
        Case Asc(".") 'unless one exists already
        If InStr(1, Me.TextBox1.Text, ".") > 0 Then
            KeyAscii = 0  'return a non-printing character
        End If
    Case Else
        KeyAscii = 0 'return a non-printing character
    End Select

End Sub

Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    'Block character input other than letters, hyphens, periods, and space
    ' For example, for title, forename and surname, eg; Mr. John Doe.
    
    Select Case KeyAscii
        'accept upper and lower case letters
        Case Asc("a") To Asc("z"), Asc("A") To Asc("Z")
        Case Asc("-"), Asc("."), Asc(" ")
            'ok provided on at least the third character
            If Me.TextBox2.SelStart < 2 Then 'zero is first
                KeyAscii = 0 'return a non-printing character
            End If
        Case Else
        KeyAscii = 0 'return a non-printing character
    End Select

End Sub

See Also[edit | edit source]

External Links[edit | edit source]


Validate with the Like Operator

Summary[edit | edit source]

This VBA example can be run in any of the commonly used Microsoft Office applications. The examples on this page make use of the Like operator to compare strings. The first example shows how to check that a string conforms to the correct format of the United Kingdom's National Insurance Number (NINO), a number used in much the same way as the US Social Security Number (SSN). The rules for the format are clear so it makes a good example. Unlike examples elsewhere in this set that check for illegal characters while they are being entered, this method is carried out only when the user has completed the entry.

The VBA Code[edit | edit source]

  • The code needs a user form called Userform1, two text boxes, TextBox1 and TextBox2, and a command button called CommandButton1. Set the UserForm1 property ShowModal to false for convenient study. Copy the code below into the three respective modules and save the workbook with an xlsm file suffix.
  • When the workbook is opened, the user form will be displayed. Type a number format into TextBox1 and when complete, press the tab key to move to the next textbox. If the number format is correct then the insertion point will move, but if not it will stay in the faulty text ready for correction. Setting the Cancel argument of BeforeUpdate() to true prevents the move.
  • Note that the Before_Update() event will not run at all unless a change has been made the text since the last time that the insertion point entered the box. So, to labor the point, after leaving the box, if the user clicks in it again without changes, the event does not run when moving on. If this poses a problem then consider the use of the Exit event for testing.
  • See also Input Boxes for a number of other validation-related procedures.

Code Changes[edit | edit source]

There are no changes so far.

For the ThisWorkbook Module[edit | edit source]

Private Sub Workbook_Open()
    ' Runs when workbook opens
    
    Load UserForm1
    UserForm1.Show

End Sub

For the UserForm1 Module[edit | edit source]

Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    'Runs on exit from the textbox provided that changes to text were made.
    'Setting Cancel to True keeps the insertion point in the text
    'instead of tabbing on.
    
    If IsNINO(TextBox1.Value) Then
        'all ok
    Else
        Cancel = True
    End If

End Sub

For the Standard Module[edit | edit source]

Sub testIsNINO()
    'run this to test the IsNINO procedure
    
    Dim sIn As String
    
    'set nino here to test
    sIn = "QQ123456A"
    
    MsgBox IsNINO(sIn)

End Sub

Function IsNINO(sIn As String) As Boolean
    ' Checks format of UK National Insurance Number (NINO)
    ' Converts to upper case for comparison
   
   'NOTES: Ref:National Insurance Numbers (NINOs): Format and Security:
   '       https://www.gov.uk/hmrc-internal-manuals/national-insurance-manual/nim39110
   'A NINO is made up of two letters, six numbers and a final letter, which is always A, B, C, or D.
   'D, F, I, Q, U, and V are not used as first or second letter of prefix.
   'Letter O is not used as the second letter of prefix.
   'Prefix combinations BG, GB, KN, NK, NT, TN and ZZ are not to be used.
   'Suffix characters can be only A,B, C,or D. (Elsewhere in examples space has been included here.)
       
    Dim bTemp As Boolean
    Const s1 As String = "[ABCEGHJKLMNOPRSTWXYZ]" 'alphabet less D, F, I, Q, U, and V; pattern for the first letter
    Const s2 As String = "[ABCEGHJKLMNPRSTWXYZ]"  'alphabet less D, F, I, O , Q, U, and V; pattern for the second letter
    Const s3 As String = "######"                 'includes only six integers; pattern for the six integers
    Const s4 As String = "[ABCD]"                 'includes only A, B, C, or D; pattern for the end letter
    
    ' Four parts of number to check are each in square brackets
    ' Right hand side of like operation concatenates
    ' all four pattern strings as one. Notice that the alpha patterns here make
    ' use of long format notation where every character permitted has been included.
    ' Instead, the alpha patterns could have been expressed as ranges; eg; "[ABCD]" is same as "[A-D]"
    bTemp = UCase(sIn) Like s1 & s2 & s3 & s4

    If bTemp Then
        ' Check for illegal pairs
        Select Case Left$(UCase(sIn), 2)
            Case "BG", "GB", "KN", "NK", "NT", "TN", "ZZ"
                IsNINO = False
                MsgBox "Illegal prefix pair detected."
                Exit Function
            Case Else
                IsNINO = True
                Exit Function
        End Select
    Else
        MsgBox "Illegal characters detected."
        IsNINO = False
        Exit Function
    End If

End Function

See Also[edit | edit source]

External Links[edit | edit source]


Delays Past Midnight

Summary[edit | edit source]

This VBA module delays for a specified number of seconds. It will work in any MS Office application that can run VBA. The following points are worth noting:

  • Most delay procedures have problems at midnight when the Timer function resets, so code that depends on the difference of two values that span that time will be in error, and will perhaps cause a failure. This procedure avoids such problems by also compensating for the number of lapsed days. As such it will be found useful in timing and clock applications, if not for measuring time, at least for deciding when the display is to be updated. For example; running a delay of twenty seconds from ten seconds to midnight (clock count 86390) to ten seconds after midnight (supposed clock count 86410) would reset at midnight, and would never reach the required end value. The problem is solved by adding one count of 86400 (the number of seconds in one day) to the stepped value for each time that a date transition is made.
  • The anticipated resolution of the procedure is about 10-16mS, consistent with that of the system timer. It is perhaps of interest to note that the GetTickCount API while able to accept millisecond parameters is still limited to the same 10-16mS resolution of the system timer.
  • The procedure parameter can take on integers and fractions of a second, provided comments about resolution are borne in mind.

The Code[edit | edit source]

Copy the following VBA code into a standard module in Excel, Word, or any other Office application that supports VBA.

Option Explicit

Sub testDelay()
    'tests delay procedure
    
    MsgBox DelaySecs(1.1)    'seconds

End Sub

Function DelaySecs(nSecs As Single) As Boolean
    'Delays for nSecs SECONDS.
    'Avoids midnight reset problem.
    'Typical resolution 10-16mS.
    
    Dim StartDate As Date
    Dim StartTime As Single
    Dim TimeNow As Single
    Dim Lapsed As Single
    
    'get launch date and current timer
    StartTime = Timer
    StartDate = Date
    
    'then loop until lapse of parameter time
    Do
        DoEvents 'allow form updates and breaks
        '86400 seconds per new day
        TimeNow = 86400 * (Date - StartDate) + Timer
        Lapsed = TimeNow - StartTime
    Loop Until Lapsed >= nSecs
    'MsgBox Lapsed
    
    DelaySecs = True
    
End Function

See Also[edit | edit source]


Time Lapsed Between Dates

Summary[edit | edit source]

This module contains VBA code to calculate the lapsed time between two fully expressed dates; that is, containing both date and time information. It can run in any MS Office applications like Excel that can run VBA code.

  • This procedure shows how to extract integer values of the time components from a date variable rather than the more usual string representation of a date. That is to say, assuming that the difference between two dates is two days, to extract the integer two instead of some date string for the year 1900.
  • Date variables contain a combination of both dates and times, but they need not do so. Some have only dates and some have only times, and when converted to the single data type, they can be seen to represent days in their integer parts and times in their fractions. Although the input parameters can contain any date variables, exact results are obtained only when both times and dates are included in each parameter. If time data is missing from a date, the calculation is still performed but uses midnight as the assumption.
  • The integer part of a date-converted-to-single is just the number of days since 31 Dec 1899 . It follows then that negative integer parts describe the days before that reference date. In fact the date function can be used for dates in the Gregorian calendar from Aug 2, 718 through Dec 31, 9999, though this differs when other calendars are in use. Add integers to, or subtract integers from date variables to modify the date by that number of days. Subtraction also applies.
  • The fractional part of a date represents a part of a day. The individual parts of time within it can be obtained as follows; multiply the date variable by 86400 to find the whole-seconds; by 1440 for whole-minutes; and by 24 for whole-hours. Then convert these results to the single data type before taking each integer part. To modify an existing date variable by a number of seconds, we simply add 1/86400 to it for each second; 1/1440 per minute, 1/24 per hour, and as stated earlier, whole units for days. Subtraction also applies.
  • Various functions also exist to simplify date-time handling.

The Code Module[edit | edit source]

Copy all of the VBA code below into a standard module.

  • Run the top procedure to test the function. Two examples are given; one for exact date-time data and another where some time data is missing.
  • The output result is a colon-separated string, containing any of a selection of formats; seconds only, minutes-seconds, hours-minutes-seconds, or days-hours-minutes-seconds. The format option is set with sConfig, and the optional units label is returned in sLabel.
  • The procedure's detail is useful. The procedure LapsedTime() illustrates the basics of multi-component extraction, as compared to the use of the VBA DateDiff function's counting intervals of one type.
Option Explicit

Sub testLapsedTime()
    'Run this to test LapsedTime()
    'For both fully expressed and
    'partially expressed date-times
    
    Dim dDateTimeStart As Date
    Dim dDateTimeEnd As Date
    Dim sOut As String, sLab As String

'EXACT LAPSED TIME FOR TWO DATE-TIME VALUES
    
    'set two exact date-times for calculation
    dDateTimeStart = #1/5/2019 1:20:10 PM# '
    dDateTimeEnd = #1/7/2019 2:37:20 PM#
    
    'exactly 2 days, 1 hours, 17 mins, and 10 seconds apart
    sOut = LapsedTime(dDateTimeEnd, dDateTimeStart, "dhms", sLab)
    MsgBox "Exact Lapsed Time:" & vbCrLf & "For fully expressed date-times:" & vbCrLf & vbCrLf & _
    Format(dDateTimeEnd, "mmm dd yyyy" & ", hh:mm:ss") & " End Time" & vbCrLf & _
    Format(dDateTimeStart, "mmm dd yyyy" & ", hh:mm:ss") & " Start Time" & vbCrLf & vbCrLf & _
    sOut & " , " & sLab

'WITH SOME TIME INFO MISSING - DEFAULTS TO MIDNIGHT
    
    'set the incomplete date-times for calculation
    'first item has no time data so DEFAULTS TO MIDNIGHT
    dDateTimeStart = #1/5/2019# 'assumes time 0:0:0
    dDateTimeEnd = #1/7/2019 2:37:20 PM#
    
    'default time given as 2 days, 14 hours, 37 mins, and 20 seconds apart
    sOut = LapsedTime(dDateTimeEnd, dDateTimeStart, "dhms", sLab)
    MsgBox "Default value of Lapsed Time:" & vbCrLf & "When time data is missing," & vbCrLf & _
    "midnight is assumed:" & vbCrLf & vbCrLf & _
    Format(dDateTimeEnd, "mmm dd yyyy" & ", hh:mm:ss") & " End Time" & vbCrLf & _
    Format(dDateTimeStart, "mmm dd yyyy") & " Start Time" & vbCrLf & "becomes " & vbCrLf & _
    Format(dDateTimeStart, "mmm dd yyyy" & ", hh:mm:ss") & " Start Time" & vbCrLf & vbCrLf & _
    sOut & " , " & sLab

End Sub

Function LapsedTime(dTimeEnd As Date, dTimeStart As Date, _
      sConfig As String, Optional sLegend As String) As String
    'Returns difference of two dates (date-times) in function name.
    'Choice of various colon-separated outputs with sConfig.
    'and Optional format label found in string sLegend
    
    Dim sOut As String
    Dim dDiff As Date
        
    'Parameter Options for sConfig
    ' "s"    output in seconds. Integer.
    ' "ms"   output in minutes and seconds. mm:ss
    ' "hms"  output in hours, minutes and seconds. hh:mm:ss
    ' "dhms" output in days, hours, minutes and seconds. integer:hh:mm:ss
    
    'test parameters
    If Not IsDate(dTimeStart) Then
        MsgBox "Invalid parameter start date - closing."
    ElseIf Not IsDate(dTimeEnd) Then
        MsgBox "Invalid parameter end date - closing."
        Exit Function
    End If
    
    'difference as date-time data
    dDiff = dTimeEnd - dTimeStart
  
    'choose required output format
    Select Case sConfig
    Case "s" 'output in seconds.
        sOut = Int(CSng(dDiff * 24 * 3600))
        sLegend = "secs"
    Case "ms" 'output in minutes and seconds
        sOut = Int(CSng(dDiff * 24 * 60)) & ":" & Format(dDiff, "ss")
        sLegend = "mins:secs"
    Case "hms" 'output in hours, minutes and seconds
        sOut = Int(CSng(dDiff * 24)) & ":" & Format(dDiff, "nn:ss")
        sLegend = "hrs:mins:secs"
    Case "dhms" 'output in days, hours, minutes and seconds
        sOut = Int(CSng(dDiff)) & ":" & Format(dDiff, "hh") _
            & ":" & Format(dDiff, "nn") & ":" & _
            Format(dDiff, "ss")
        sLegend = "days:hrs:mins:secs"
    Case Else
        MsgBox "Illegal format option - closing"
        Exit Function
    End Select
    
    LapsedTime = sOut

End Function

See Also[edit | edit source]


Date-Time String Formats

Summary[edit | edit source]

This page lists VBA code to format date-time strings and intervals. It is for use in Microsoft Excel and similar applications that run VBA code. The procedure takes a date variable and returns it as a formatted string. The parameter nOpt sets the chosen format from a set that includes dates, times, or intervals. There are two main format types in use:

  • Strings containing a date, are those that display a day, month, and year, with or without times added to them. The important point here is that the number of days stored in the date variable is intended to be displayed as a date, as opposed to an integer. For example, the integer stored for 25 December 2018 is just 43459 and is only converted for display. Nearly all of the format options in the code module are of this basic type.
  • Strings containing time intervals, are intended to display the number of days as an integer, as opposed to displaying it as a conventional date; that is, in the format d:h:m:s, like a stopwatch. If a date format is selected for an intended for an interval of a couple of days or so, then a very early date near 1900 will be displayed. That said, such an error might still be useful for those curious about the actual number of days associated with a particular date. One time interval format has been included to illustrate the difference in the method, while a full set of these can be found on an adjacent page.
  • Date-time variable assignment examples can be found in the procedure DateAssign().

VBA Code Module[edit | edit source]

Copy the entire VBA code listing into a standard module, select a formatting option (1-15) in the top procedure , then run it.

Modifications[edit | edit source]

  • 10 Jan 2019, DateTimeFormat() code modified to include one interval format.
Option Explicit

Sub testDateFormats()
    'Run this to format a date-time
    
    Dim dDate As Date, nOpt As Integer

    'set test date here - examples
    dDate = #1/9/2019 1:45:02 PM#
    
    'set format option 1-14 for dates
    'and 15 to format as a time interval
    nOpt = 14
        
    MsgBox DateTimeFormat(dDate, nOpt)

End Sub

Function DateTimeFormat(dDate As Date, Optional ByVal nOpt As Integer = 1) As String
    'Returns dDate as a date-time display string in function name.
    'Optional format choice with nOpt= (1-14) for dates, and nOpt=(15) for intervals.
    
    Dim sOut As String
    
    If Not IsDate(dDate) Then
        MsgBox "Parameter not a date - closing"
        Exit Function
    End If
    
    Select Case nOpt                                   'returns for #1/9/2019 1:45:02 PM#
                                                       '(9th January 2019 at 13:45:02)
        Case 1
            sOut = Format(dDate, "dd\/mm\/yy")         '09/01/19
        Case 2
            sOut = Format(dDate, "d mmm yy")           '9 Jan 19
        Case 3
            sOut = Format(dDate, "dd:mm:yy")           '09:01:19
        Case 4
            sOut = Format(dDate, "d mmmm yyyy")        '9 January 2019
        Case 5
            sOut = Format(dDate, "mmmm d, yyyy")       'January 9, 2019
        Case 6
            sOut = Format(dDate, "dddd, dd\/mm\/yyyy") 'Wednesday, 09/01/2019
        Case 7
            sOut = Format(dDate, "dddd, mmm d yyyy")   'Wednesday, Jan 9 2019
        Case 8
            sOut = Format(dDate, "dddd, d mmmm yyyy")  'Wednesday, 9 January 2019
        Case 9
            sOut = Format(dDate, "y")                  '9, day in year (1-365)
        Case 10
            sOut = sOut = Format(dDate, "h:m:s")       '13:45:2 'no leading zeros
        Case 11
            sOut = Format(dDate, "h:m:s AM/PM")        '1:45:2 PM 'no leading zeros
        Case 12
            sOut = Format(dDate, "hh:mm:ss")           '13:45:02 'leading zeros added
        Case 13
            sOut = Format(dDate, "ddmmyy_hhmmss")      '090119_134502, leading zeros added
        Case 14
            sOut = Format(dDate, "dddd, d mmmm yyyy, hh:mm:ss AM/PM") 'Wednesday, 9 January 2019, 01:45:02 PM
        Case 15
            sOut = Format(Int(CSng(dDate)), "###00") & ":" & Format(dDate, "hh:nn:ss") 'time interval format
        Case Else
            MsgBox "Option out of bounds in DateTimeFormat() - closing"
    End Select
    
    DateTimeFormat = sOut

End Function

Sub DateAssign()
    'date-time assignment examples
    
    Dim dD1 As Date, dD2 As Date, dD3 As Date
    Dim dD4 As Date, dD5 As Date, dD6 As Date
    Dim dD7 As Date, dD8 As Date, dD9 As Date
    Dim dD10 As Date, dD11 As Date, dd12 As Date
       
    'These three assignment methods are equivalent
    'and will display 25 Dec 2018 only
    dD1 = #12/25/2018#              'literal
    dD2 = DateValue("25 Dec 2018")  'string
    dD3 = DateSerial(2018, 12, 25)  'integer
    
    'These three assignment methods are equivalent
    'and will display 10:05:07 AM only
    dD4 = #10:05:07 AM#            'literal
    dD5 = TimeValue("10:05:07")    'string
    dD6 = TimeSerial(10, 5, 7)      'integer
            
    'These six combined methods are equivalent
    'and will display 25 Dec 2018 10:05:07 AM
    dD7 = #12/25/2018 10:05:07 AM#
    dD8 = dD1 + dD4
    dD9 = DateValue("25 dec 2018") + TimeValue("10:05:07")
    dD10 = DateSerial(2018, 12, 23) + TimeSerial(58, 4, 67)
    dD11 = dD1 + (0 / 1) + (10 / 24) + (5 / 1440) + (7 / 86400)
    dd12 = DateValue("27 dec 2018") - (2 / 1) + (10 / 24) + (5 / 1440) + (7 / 86400)
        
    'confirm equality of results in immediate window
    Debug.Print CStr(dD7) = CStr(dD8)
    Debug.Print CStr(dD8) = CStr(dD9)
    Debug.Print CStr(dD9) = CStr(dD10)
    Debug.Print CStr(dD10) = CStr(dD11)
    Debug.Print CStr(dD11) = CStr(dd12)
    Debug.Print dD1
    Debug.Print dD4
    Debug.Print dD7
    MsgBox dD7
    
End Sub


Avoiding Change Event Recursion

Summary[edit | edit source]

  • This VBA code is intended to run in Microsoft Office applications that can run macros, like Excel or Word.
  • It provides two different examples of a text box change event, one for TextBox1 and another for TextBox2.
  • It will be noted that on displaying the form and entering one character into TextBox1, the resulting number found there is about 290 or so; this is coded to show the number of iterations of the change event that have taken place.
  • Doing the same in TextBox2 shows that there has been just one run of the event.
  • The code of the TextBox2_Change event avoids multiple runs of the procedure, avoiding the possibility of false results in certain circumstances.

The VBA Code[edit | edit source]

Code Changes[edit | edit source]

For the ThisWorkbook Module[edit | edit source]

'...............................................
' Notes: Code needs a user form named UserForm1,
' with two text boxes, TextBox1 and Textbox2,
'...............................................

Private Sub Workbook_Open()
    'Runs on opening the workbook
   
    Load UserForm1
    UserForm1.Show

End Sub

For the UserForm1 Module[edit | edit source]

Private Sub TextBox1_Change()
    ' This Change event runs about 294 times
    ' for each character entered
    
    Static nC As Long
    
    'yield to commands-just in case
    DoEvents
    
    'increment for each iteration
    nC = nC + 1
    
    'this line causes this procedure to run again
    TextBox1.Value = nC

End Sub

Private Sub TextBox2_Change()
    ' This Change event runs only once
    ' for each character entered
    
    Static nC As Long
    Static bEnableEvents As Boolean
    
    'yield to commands-just in case
    DoEvents
    
    ' increment for each iteration
    nC = nC + 1
    
    ' false to start then true after that
    If bEnableEvents = True Then
        Exit Sub
    End If
    bEnableEvents = True

    ' this runs only once
    TextBox2.Value = nC
    
    ' reset flag
    bEnableEvents = False

End Sub

See Also[edit | edit source]

External Links[edit | edit source]


CommandButton Toggle

Summary[edit | edit source]

This VBA code module is made for Microsoft Excel but is easily adapted for use in other Office applications that can run VBA with user forms:

  • Two improved CommandButton_Click() procedures are provided. They show better emphasis when buttons are prssed. CmmandButton1_Click() has a toggle action, for example to set either one of two possible modes, and CommandButton2_Click() performs the usual task of one function. In each case:
    • The user-set captions change in transition to reflect the current state of the buttons, for example Running etc. This can be of interest in the toggle states or when a procedure takes a long time to run.
    • The button size is swelled about its center. This avoids enlargement from a fixed top-left point. The amount of the increase can be set within the procedure.
    • The background and font color of the buttons are set in code, so are easily modified. Separate colors can be used for the two states.
    • The Me.Repaint lines ensure that the button formats update immediately. If they are not present the procedures will start, and perhaps end, before that was done. Without Me.Repaint, but when DoEvents exists in the procedure-to-run, the repaint might still appear to work normally, until a procedure is run that does not require DoEvents. For those who intend to study this point, it is shown up best in the CommandButton2_Click() procedure.

The Code Module[edit | edit source]

Copy the UserForm_Initialize(), CommandButton1_Click(), and CommandButton2_Click() procedures into the UserForm module of an Excel project. This can be achieved by first inserting a form called UserForm1, with one CommandButton called CommandButton1 and another CommandButton2. Double-click within the form in design mode to access its module. The Workbook_Open() procedure goes into the ThisWorkbook module. Then, save the workbook, and run Workbook_Open() (or re-open the workbook) to test the buttons on the form.

Modifications[edit | edit source]

  • 20 Jan 2019, added the previously omitted Me.Repaint code lines
Private Sub Workbook_Open()
    'run this to show form
    
    Load UserForm1
    UserForm1.Show

End Sub


Option Explicit

Private Sub UserForm_Initialize()
        
    With CommandButton1
        .Height = 50
        .Width = 50
        .Caption = "Turn ON"
        .BackColor = RGB(255, 205, 183)
    End With
    With CommandButton2
        .Height = 50
        .Width = 50
        .Caption = "Turn ON"
        .BackColor = RGB(255, 205, 183)
    End With

End Sub

Private Sub CommandButton1_Click()
    'TOGGLES caption, color and size-about-center
    'of a typical CommandButton control, between
    'say, two stable modes of working.
            
    Dim nInc As Integer, n As Long
    
    'set size increase (say 0 to 10)
    nInc = 8
        
    With CommandButton1
        'run the OFF code
        If .Caption = "Turn OFF" Then
            .Width = .Width - nInc
            .Height = .Height - nInc
            .Caption = "Turn ON"
            .Left = .Left + nInc / 2
            .Top = .Top + nInc / 2
            .BackColor = RGB(255, 205, 183)
            .ForeColor = RGB(0, 0, 0)
             Me.Repaint 'redraw form
            
            'add procedure here for the OFF state
            '(simulated here with a short delay)
            For n = 1 To 100000
                DoEvents 'yield as required
            Next
        
        Else 'run the ON code
            .Width = .Width + nInc
            .Height = .Height + nInc
            .Caption = "Turn OFF"
            .Left = .Left - nInc / 2
            .Top = .Top - nInc / 2
            .BackColor = RGB(255, 217, 183)
            .ForeColor = RGB(0, 0, 0)
            Me.Repaint 'redraw form
            
            'add procedure here for the ON state
            '(simulated here with a short delay)
            For n = 1 To 100000
                DoEvents 'yield as required
            Next
        
        End If
    End With

End Sub

Private Sub CommandButton2_Click()
    'Changes color and size-about-center
    'of a typical CommandButton control,
    'holds formats during process
    'and restores all on exit.
                
    Dim nInc As Integer, n As Long
    
    'set size increase (say 0 to 10)
    nInc = 8
    
    'detect OFF state
    With CommandButton2
        If .Caption = "Turn ON" Then
            .Width = .Width + nInc
            .Height = .Height + nInc
            .Caption = "Running"
            .Left = .Left - nInc / 2
            .Top = .Top - nInc / 2
            .BackColor = RGB(255, 217, 183)
            .ForeColor = RGB(0, 0, 0)
        End If
    End With
    Me.Repaint 'redraw form
    
            'add procedure here for the ON state
            '(simulated here with a short delay)
            For n = 1 To 100000
                DoEvents 'yield as required
            Next
    
    'restore button just before exit
    With CommandButton2
        If .Caption = "Running" Then
            .Width = .Width - nInc
            .Height = .Height - nInc
            .Caption = "Turn ON"
            .Left = .Left + nInc / 2
            .Top = .Top + nInc / 2
            .BackColor = RGB(255, 205, 183)
            .ForeColor = RGB(0, 0, 0)
        End If
    End With
    Me.Repaint 'redraw form

End Sub

See Also[edit | edit source]


Styling User Forms

Summary[edit | edit source]

  • FormatForm() is used to format a single specified userform with pre-selected colorings and fonts. This replaces a previous procedure to format all open userforms. Assumes that a userform called UserForm1 exists.
  • The procedure AutoFormat() performs auto-sizing and layout for simple array data, so that the display and label bar is tabular in appearance, regardless of the length of the various data. This latter procedure also has facilities to transpose the input in case it is needed.

Code Modules[edit | edit source]

Last Modified 10 Jun 2017[edit | edit source]

Corrected name of TransposeArr2D() in Autoformat(). (12 Jul 2019)
Replaced multi-form procedure with single-form procedure FormatForm().(18 Jan 19)
Changed code to more general TypeName in FormatAllLoadedUserForms(28 June 18)
Added transpose function, previously omitted (10 Jun 2017)
Removed font procedures to their new page
Reduced number of AutoFormat() controls.(17 Nov 2016)
Added GetTextPoints(). (17 Nov 2016)

For Typical ThisWorkbook Module[edit | edit source]

Private Sub Workbook_Open()
   'Shows typical use of form format function
   'runs at workbook opening
   'Assumes that a user form called UserForm1 exists
   
   'load the form
   Load UserForm1
      
   'format the form
   FormatForm UserForm1
   
   'show the form
   UserForm1.Show
   
   'do other stuff then...
   
   'repaint the form
   UserForm1.Repaint
End Sub

For the Standard Module[edit | edit source]

Function FormatForm(vForm As Variant) As Boolean
    'applies color and text formats
    'to parameter user form object and its controls
    'Be sure to repaint the user form after this function    
    
    Dim oCont As msforms.Control
    Dim nColForm As Single, nColButtons As Single
    Dim nColBox As Single, nColLabels As Single
    Dim nColGenFore As Single, nColBoxText As Single
               
    'set the color scheme here - add as required - eg:
    nColForm = RGB(31, 35, 44)          'main form background
    nColButtons = RGB(0, 128, 128)      'all button backgrounds
    nColGenFore = RGB(255, 255, 255)    'all button text
    nColBox = RGB(0, 100, 0)            'all text box backgrounds
    nColBoxText = RGB(255, 255, 190)    'all text box text
    nColLabels = RGB(23, 146, 126)      'all label text
        
    'current user form name
    'MsgBox vForm.Name
    
    'apply user form formats here
    vForm.BackColor = nColForm
   
   'apply individual control formats
    For Each oCont In vForm.Controls
        'MsgBox oCont.Name
        With oCont
            Select Case TypeName(oCont)
            Case "TextBox"
                .BackColor = nColBox
                .ForeColor = nColBoxText
                .Font.Name = "Tahoma"
                .Font.Size = 8
            Case "ListBox"
                .BackColor = nColBox
                .ForeColor = nColBoxText
                .Font.Name = "Tahoma"
                .Font.Size = 8
            Case "ComboBox"
                .BackColor = nColBox
                .ForeColor = nColBoxText
                .Font.Name = "Tahoma"
                .Font.Size = 8
            Case "Frame"
                .BackColor = nColForm
                .ForeColor = nColGenFore
                .Font.Name = "Tahoma"
                .Font.Size = 8
            Case "CommandButton", "ToggleButton"
                .BackColor = nColButtons
                .ForeColor = nColGenFore
                .Font.Name = "Tahoma"
                .Font.Size = 8
            Case "SpinButton"
                .BackColor = nColButtons
                .ForeColor = nColGenFore
            Case "OptionButton"
                .BackStyle = fmBackStyleTransparent
                .ForeColor = nColGenFore
                .Font.Name = "Tahoma"
                .Font.Size = 8
            Case "CheckBox"
                .BackStyle = fmBackStyleTransparent
                .ForeColor = nColGenFore
                .Font.Name = "Tahoma"
                .Font.Size = 8
            Case "Label"
                .BackStyle = fmBackStyleTransparent
                .ForeColor = nColLabels
                .Font.Name = "Tahoma"
                .Font.Size = 8
            End Select
        End With
   Next oCont
   
   FormatForm = True
    
End Function

Sub AutoFormat(vA As Variant, Optional bTranspose As Boolean = False)
    ' Takes array vA of say, 4 columns of data and
    ' displays on textbox in tabular layout.
    ' Needs a userform called ViewVars and a textbox
    ' called Textbox1.  Code will adjust layout.
    ' Transpose2DArr used only to return data to (r, c) format.
    
    Dim vB As Variant, vL As Variant, vR As Variant
    Dim r As Long, c As Long, m As Long, sS As String
    Dim nNumPadSp As Long, TxtLab As Control, MaxFormWidth As Long
    Dim sAccum As String, sRowAccum As String, bBold As Boolean
    Dim nLineLen As Long, BoxFontSize As Long, BoxFontName As String
    Dim sLabAccum As String, nLabPadSp As Long, oUserForm As Object
    Dim Backshade As Long, BoxShade As Long, BoxTextShade As Long
    Dim ButtonShade As Long, ButtonTextShade As Long
    Dim Lb1 As Long, Ub1 As Long, Lb2 As Long, Ub2 As Long
    Dim TextLength As Long, bItalic As Boolean
    
    ' decide to transpose input or not
    If bTranspose = True Then
        TransposeArr2D vA, vR
        vA = vR
    End If
        
    ' get bounds of display array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    ReDim vL(Lb2 To Ub2) ' make labels array
    ReDim vB(Lb2 To Ub2) ' dimension column width array
    
    '--------------------------------------------------------------
    '                   SET USER OPTIONS HERE
    '--------------------------------------------------------------
    ' set the name of the userform made at design time
    Set oUserForm = ViewVars
    
    ' set limit for form width warning
    MaxFormWidth = 800
    
    ' make column labels for userform - set empty if not needed
    vL = Array("Variable", "Procedure", "Module", "Project")
    
    ' colors
    Backshade = RGB(31, 35, 44)          'almost black -   used
    ButtonShade = RGB(0, 128, 128)       'blue-green - not used
    BoxShade = RGB(0, 100, 0)            'middle green -   used
    ButtonTextShade = RGB(230, 230, 230) 'near white - not used
    BoxTextShade = RGB(255, 255, 255)    'white -          used
    ' Font details are to be found below
    '--------------------------------------------------------------
    
    ' find maximum width of array columns
    ' taking account of label length also
    For c = Lb2 To Ub2
        m = Len(vL(c)) 'label
        For r = Lb1 To Ub1
            sS = vA(r, c) 'value
            If Len(sS) >= m Then
                m = Len(sS)
            End If
        Next r
        'exits with col max array
        vB(c) = m
        m = 0
    Next c
   
   ' For testing only
   ' shows max value of each column
'   For c = LB2 To UB2
'       MsgBox vB(c)
'   Next c
    
    For r = Lb1 To Ub1
        For c = Lb2 To Ub2
            If c >= Lb2 And c < Ub2 Then
                ' get padding for current element
                nNumPadSp = vB(c) + 2 - Len(vA(r, c))
            Else
                ' get padding for last element
                nNumPadSp = vB(c) - Len(vA(r, c))
            End If
                ' accumulate line with element padding
            sAccum = sAccum & vA(r, c) & Space(nNumPadSp)
                ' get typical line length
            If r = Lb1 Then
                sRowAccum = sRowAccum & vA(Lb1, c) & Space(nNumPadSp)
                nLineLen = Len(sRowAccum)
            End If
        Next c
                ' accumulate line strings
                sAccum = sAccum & vbNewLine
    Next r

    ' accumulate label string
    For c = Lb2 To Ub2
        If c >= Lb2 And c < Ub2 Then
            ' get padding for current label
            nLabPadSp = vB(c) + 2 - Len(vL(c))
        Else
            ' get padding for last element
            nLabPadSp = vB(c) - Len(vL(c))
        End If
        ' accumulate the label line
        sLabAccum = sLabAccum & vL(c) & Space(nLabPadSp)
    Next c
        
    ' load user form
    Load oUserForm
    
    '================================================================
    '       SET FONT DETAILS HERE. THESE AFFECT ALL AUTOSIZING.
    '================================================================
    BoxFontSize = 12         'say between 6 to 20 points
    bBold = True             'True for bold, False for regular
    bItalic = False          'True for italics, False for regular
    BoxFontName = "Courier"  'or other monospaced fonts eg; Consolas
    '================================================================
      
    ' make the labels textbox
    Set TxtLab = oUserForm.Controls.Add("Forms.TextBox.1", "TxtLab")
    
    ' format the labels textbox
    With TxtLab
        .WordWrap = False
        .AutoSize = True 'extends to fit text
        .Value = ""
        .font.Name = BoxFontName
        .font.SIZE = BoxFontSize
        .font.Bold = bBold
        .font.Italic = bItalic
        .ForeColor = BoxTextShade
        .Height = 20
        .Left = 20
        .Top = 15
        .Width = 0
        .BackStyle = 0
        .BorderStyle = 0
        .SpecialEffect = 0
    End With
    
    'apply string to test label to get length
    TxtLab.Value = sLabAccum & Space(2)
    TextLength = TxtLab.Width
    'MsgBox TextLength
    
    'format userform
    With oUserForm
        .BackColor = Backshade
        .Width = TextLength + 40
        .Height = 340
        .Caption = "Redundant variables list..."
    End With
      
    ' check user form is within max width
    If oUserForm.Width > MaxFormWidth Then
        MsgBox "Form width is excessive"
        Unload oUserForm
        Exit Sub
    End If
    
    'format the data textbox
    With oUserForm.TextBox1
        .ScrollBars = 3
        .WordWrap = True
        .MultiLine = True
        .EnterFieldBehavior = 1
        .BackColor = BoxShade
        .font.Name = BoxFontName
        .font.SIZE = BoxFontSize
        .font.Bold = bBold
        .font.Italic = bItalic
        .ForeColor = BoxTextShade
        .Height = 250
        .Left = 20
        .Top = 40
        .Width = TextLength
        .Value = sAccum
    End With
    
    'show the user form
    oUserForm.Show

End Sub

Function TransposeArr2D(vA As Variant, Optional vR As Variant) As Boolean
        
    '---------------------------------------------------------------------------------
    ' Procedure : Transpose2DArr
    ' Purpose   : Transposes a 2D array; rows become columns, columns become rows
    '             Specifically, (r,c) is moved to (c,r) in every case.
    '             Options include, returned in-place with the source changed, or
    '             if vR is supplied, returned in that instead, with the source intact.
    '---------------------------------------------------------------------------------
    
    Dim vW As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim r As Long, c As Long, bWasMissing As Boolean
    
    'find whether optional vR was initially missing
    bWasMissing = IsMissing(vR)
    If Not bWasMissing Then Set vR = Nothing
    
    'use a work array
    vW = vA
    
    'find bounds of vW data input work array
    loR = LBound(vW, 1): hiR = UBound(vW, 1)
    loC = LBound(vW, 2): hiC = UBound(vW, 2)
    
    'set vR dimensions transposed
    'Erase vR 'there must be an array in the variant to erase
    ReDim vR(loC To hiC, loR To hiR)
    
    'transfer data
    For r = loR To hiR
        For c = loC To hiC
            'transpose vW into vR
            vR(c, r) = vW(r, c)
        Next c
    Next r
    
    'find bounds of vW data input work array
'    loR = LBound(vR, 1): hiR = UBound(vR, 2)
'    loC = LBound(vR, 2): hiC = UBound(vR, 2)


TRANSFERS:
    'decide whether to return in vA or vR
    If Not bWasMissing Then
        'vR was the intended return array
        'so leave vR as it is
    Else:
        'vR is not intended return array
        'so reload vA with vR
        vA = vR
    End If
    
    'return success for function
    TransposeArr2D = True
    
End Function


Check if a Workbook has VBA code

Summary[edit | edit source]

This VBA code module is made for Excel, but is easily adapted for other MS Office applications. It checks a workbook to see if it contains any useful VBA dimensional or structural code. Line counting has been found to be less reliable than this since even empty modules will show two lines of code each.

The Code Module[edit | edit source]

  • Place all of the code below into the same standard module, and identify the test workbook address in wb.
  • Then, run the procedure CheckForVBA to check whether or not the test workbook contains identifiable VBA code structures.
  • The procedures first check to see that the workbook is not locked.
  • Users can modify the test keyword list in procedure ContainsVBAKeyWords.
  • The test workbook is closed again after inspection.
  • Results are shown in message boxes here, but the top section is easily modified for other uses.
Option Explicit

Sub CheckForVBA()
    'Run this procedure to know whether a specified workbook has VBA code
    'Assumes that workbook to test is in same folder and called Book2.xlsm
    'Set reference to Microsoft VBA Extensibility 5.5
    
    Dim wb As Workbook, nL As Long, bR As Boolean
    
    'set full address of workbook to test here
    'if just file name then same folder is assumed
    Set wb = Workbooks.Open("Book2.xlsm")
    
    'check for code if project is not locked
    If IsProtectedVBProject(wb) = False Then
       'check for vba code
       If WbkHasVBA(wb) = True Then
          MsgBox "Workbook " & wb.FullName & vbCrLf & _
          "CONTAINS VBA code structure."
       Else
          MsgBox "Workbook " & wb.FullName & vbCrLf & _
          "DOES NOT contain VBA code structure."
       End If
    Else
       MsgBox "The VBA Project is LOCKED;" & vbCrLf & _
              "might have VBA but unable to confirm."
    End If

    'close the test workbook
    wb.Close

End Sub

Function IsProtectedVBProject(ByVal wb As Workbook) As Boolean
    'returns TRUE if VBA is password protected, else false
        
    Dim nComp As Integer
    
    nComp = -1
    
    On Error Resume Next
       nComp = wb.VBProject.VBComponents.Count
    On Error GoTo 0
    
    If nComp = -1 Then
       IsProtectedVBProject = True
    Else
       IsProtectedVBProject = False
    End If

End Function

Private Function WbkHasVBA(ByVal wb As Workbook) As Boolean
    'returns true if workbook contains VBA, else false.
    'Code must not be locked.
    'Set reference to Microsoft VBA Extensibility 5.5
    
    Dim VBComp As VBIDE.VBComponent
    Dim VBMod As VBIDE.CodeModule
    Dim nLines As Long, sMod As String
         
    'get each module one at a time
    For Each VBComp In wb.VBProject.VBComponents
        Set VBMod = VBComp.CodeModule
        nLines = VBMod.CountOfLines
            If nLines <> 0 Then
                sMod = VBMod.Lines(1, nLines)
                'check for significant code entries
                If ContainsVBAKeyWords(sMod) Then
                   WbkHasVBA = True
                   Exit For
                End If
            End If
    Next VBComp
    
    Set VBComp = Nothing
    Set VBMod = Nothing

End Function

Function ContainsVBAKeyWords(ByVal sModule As String) As Boolean
   'Returns true if input string contains any listed word,
   'else false. User should add keywords of interest to vKeyList

   Dim vKeyList As Variant, nC As Integer, bM As Boolean
   
   'set the key list of interest here
   vKeyList = Array("End", "Dim", "Public", "Private", "Friend", "Property", _
                 "Type", "Declare", "Sub", "Function")

   'loop through keylist and compare with parameter module string
   For nC = LBound(vKeyList) To UBound(vKeyList)
      bM = sModule Like "*" & vKeyList(nC) & "*"
      If bM = True Then
         ContainsVBAKeyWords = True
         Exit For
      End If
   Next nC

End Function


Get the VBA Code String

Summary[edit | edit source]

The VBA Editor[edit | edit source]

Getting the Whole Project String[edit | edit source]

The code module below is written for Excel but is easily adapted for Word and other MS Office applications. It makes a single string out of the entire code project for the same workbook in which it is run. In the past it has been found useful when a long string is needed to test say, character frequency code. With only slight modification the individual module text can be returned, and other details.

Sub TestGetVBAProjString()
  'run this
  'assumes VBA code is not locked
  
  Dim sStr As String, nComps As Integer
  Dim vA As Variant, nTLines As Long
  
  'get whole string
  sStr = GetVBAProjString
  
  'show start of project string
  MsgBox sStr
End Sub

Function GetVBAProjString() As String
  'gets ThisWorkbook's whole VBA project string
  'Set reference to Microsoft VBA Extensibility 5.5
  
  Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
  Dim VBMod As VBIDE.CodeModule, sMod As String, sProj As String
  Dim nLines As Long
  
  'get ref to ThisWorkbook project
  Set VBProj = ThisWorkbook.VBProject
    
  'loop through VBComponents collection
  For Each VBComp In VBProj.VBComponents
    Set VBMod = VBComp.CodeModule
    nLines = VBMod.CountOfLines
      If nLines <> 0 Then
        sMod = VBMod.Lines(1, nLines)
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf & sMod
      Else 'just accum name of empty component
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf
      End If
  Next VBComp
  
  GetVBAProjString = sProj
  Set VBProj = Nothing: Set VBComp = Nothing
  Set VBMod = Nothing
  
End Function

External Links[edit | edit source]


VBA Code Indenter

Summary[edit | edit source]

  • This admittedly long code module is used to indent or format any VBA code that it finds on the clipboard.. It uses fairly standard code indenting rules, examples of which can be seen in the formatting of the code on this page. Commercial formatting utilities are now available for VBA editors in 64-bit Windows, but the code below runs, not as an add-in but as a simple VBA code module. Within reason it will work for all recent versions of Windows and Excel, and with other Microsoft Office applications that can run VBA. It is fast enough for even the most critical user.
  • It places the indented text back on the clipboard to replace the original text. The user can then paste it as he pleases.
  • The first effort has few options.
    • The depth of indenting can be set. This is done by setting the number of spaces per tab.
    • The number of consecutive blank lines can be set. This is limited to none, one, or left as they are found.
    • Existing line numbers can be preserved or removed, though no renumbering facility has been provided.
    • Shared label lines can be split onto their own lines.
    • The code routinely replaces comments that are continuations with comments on their own lines, though users can elect to avoid changes to comments altogether. If comment changes are permitted:
      • Rem comment style is optionally replaced with the apostrophe style.
      • Users can choose to insert one space after the comment apostrophe or to remove it where it already exists.

VBA Code Indenter-Formatter Module[edit | edit source]

A few points bear mention:

  • The code runs as one complete standard module. Run the procedure Indenter() to indent the clipboard content.
  • The user might also consider an optional user form to preview the indented output string (sRet in procedure Indenter) prior to Paste.
  • Select code with complete pairings to make best use of the indenter. For example, so that there are no obvious If's without End If's. That said, snippets of code, procedures, or whole modules can be indented. In fact any text with recognized VBA keywords and line breaks, will get indented. Users should set the VBA editor error settings to Break for Unhandled Errors to avoid unnecessary interruptions from the intentional raising of errors.
  • Readers who find the matter interesting might consider adding any bug reports to Discussion, and I will look at them when I can.

Work Method Used[edit | edit source]

All working is done in a module-level string array. The process is:

  • Get the clipboard string first. The method used to get the string is the same as the one listed elsewhere in this series. See Clipboard VBA, for the DataObject clipboard methods. This method replaces an earlier method using a dummy user form.
  • Load an array with the string as a set of lines. Load only the code part without any line number that may be present. Then remove the existing indentation from every line. This means any leading and lagging spaces and tabs.
  • Re-connect lines broken with continuation marks. This process avoids many line identification problems, especially from follow-on comment lines that have been folded without their own continuation marks.
  • Identify and mark the array with line types. The line types that come in closed structures, like For...Next or Sub...End Sub pairs, are especially important for indenting. These are marked as start and end line types respectively. Initially, it is not important which structures they are, just whether or not they are starts or ends. Middles such as Else also need to be identified, as well as comment, blank lines, and a large set of so-called other lines.
  • Match up corresponding start and end lines. It works like this: Starting at the top of the code; select the first start line and count it as one, then move down, incrementing both start and end counters until the two counters are equal; the matched end line is then found. After resetting the counters, move down to the second start, and repeat the process until all of the start lines have been matched. The array start lines are marked with the row numbers for the corresponding end matches.
  • Check the pair counts. If the code does not contain at least one start-end structure, or the start and end totals do not match, the user is invited to proceed or exit. A user assigned error is raised to achieve exit.
  • Assign the indents and outdent counts for the main structures. Starting at the top of the code lines, go to the first line marked as a start. Add one indent count for all of the lines that lie between that start and its corresponding end line. Move down to the next start line and repeat the process until it is done. Now, for any line anywhere in the array that is marked as a middle, outdent, that is, subtract one indent count. Indent counts are converted to spaces using an indenting option.
  • Join indent spaces to the code lines and make one string from them all. Although users can set a spacing option, four spaces to each indent unit seems to be the most useful, much as in the VBA editor itself.
  • Upload the indented string to the clipboard, then advise that it is there, ready for paste.

Code Module Modifications[edit | edit source]

15 Dec 2018: Code modified to add error when clipboard not text.
14 Dec 2018: Code modified to use DataObject copy and paste methods.
29 Mar 2017: Minor edit to GetClipboard function comment.

Option Explicit
Private sW() As String

Sub Indenter()
    ' ===============================================================================
    ' Run the sub "Indenter" to format any VBA code text that is on the clipboard.
    ' The indented version will be found on the clipboard, replacing the original.
    ' ===============================================================================
    
    Dim sClip As String, msg As String
    Dim vT As Variant, vU As Variant, vS As Variant, sRet As String
    Dim bModifyComments As Boolean, bMC As Boolean, bOnlyAposComments As Boolean
    Dim bOAC As Boolean, bApostropheSpaced As Boolean, bAS As Boolean
    Dim bSplitLabelLines As Boolean, bSL As Boolean, bKeepLineNumbers As Boolean
    Dim bKLN As Boolean, nSpacesPerIndentTab As Long, nSPIT As Long
    Dim nMaxAdjacentBlankLines As Long, nMABL As Long
    
    ' ===============================================================================
    '                          SET USER OPTIONS HERE
    ' ===============================================================================
    nSpacesPerIndentTab = 4    ' Sets number of spaces per tab - depth of indenting,
    '                          ' best settings found to be 2, 3, or 4.
    '---------------------------------------------------------------------------------
    nMaxAdjacentBlankLines = 7 ' Sets number of adjacent blank lines in output
    '                          ' 0 for none, or 1. Set > 1 to leave as found.
    '---------------------------------------------------------------------------------
    bModifyComments = False    ' True to allow other modifications to comments, and
    '                          ' changing of continuation comment groups into own-line
    '                          ' comments.  False, for no changes to comments.
    '       'set bModifyComments to true for these to have any effect;
    bOnlyAposComments = True   ' True to change any r e m style comments to
    '                          ' to apostrophe style, else false to leave as found.
    bApostropheSpaced = False  ' True to place spaces after apostrophies in
    '                          ' comments, else False to remove any single space.
    '---------------------------------------------------------------------------------
    bSplitLabelLines = False   ' True to split label lines onto own lines if they
    '                          ' are shared, else False to leave as they are found.
    '---------------------------------------------------------------------------------
    bKeepLineNumbers = True    ' True to preserve existing line numbers, if any,
    '                          ' else False to remove any numbers during indent.
    '---------------------------------------------------------------------------------
    '
    ' ================================================================================
    
    nSPIT = nSpacesPerIndentTab: nMABL = nMaxAdjacentBlankLines
    bMC = bModifyComments: bOAC = bOnlyAposComments: bAS = bApostropheSpaced
    bSL = bSplitLabelLines: bKLN = bKeepLineNumbers
    
    On Error GoTo Err_Handler
    Erase sW()                 ' erase work array
    ' ---------------------------------------------------------------------------------
    sClip = GetFromClip        '  GETS CLIPBOARD STRING
    ProjStrTo1DArr sClip, vS   '  String of lines to 1D array of lines. Base zero.
    ModifyComments vS, vT, bOAC, bAS, bMC '  Modifies comments; removes continuation
    LabelLineSplit vT, vU, bSL '  1D array to 1D array. Splits shared label lines.
    ClpToArray vU              '  1D array to 2D module array. Separates line numbers.
    JoinBrokenLines            '  2D array. Joins-up continuation lines.
    GetLineTypes               '  2D array. Marks array with line types.
    MatchPairs                 '  2D array. Matches-up starts and ends.
    CheckPairs                 '  2D array. Crude checking by pair counts.
    Indents                    '  2D array. Adds tab counts for indents
    Outdent                    '  2D array. Subtracts tab count for outdents.
    SpacePlusStr nSPIT, bKLN   '  2D array. Adds indent spaces to line strings.
    MaxBlanks sRet, nMABL      '  2D array to STRING. Also limits blank lines.
    CopyToClip sRet            ' INDENTED STRING TO CLIPBOARD
    MsgBox "The indented string is now on the clipboard."
    
    ' ---------------------------------------------------------------------------------
    Exit Sub
    
Err_Handler:
    If Err.Number <> 0 Then
        Select Case Err.Number
        Case 12345 ' raised in CheckPairs
            ' optional exit - user selected exit
            ' partial selection has mismatched structure bounds
            ' or only trivial text without structures at all
            Err.Clear
            Exit Sub
        Case 12346 ' raised in JoinBrokenLines
            ' compulsory exit
            ' partial selection breaks a statement continuation group
            Err.Clear
            Exit Sub
        Case 12347 ' raised in ModifyComments
            ' compulsory exit
            ' partial selection breaks a comment continuation group
            Err.Clear
            Exit Sub
        Case -2147221404 'clipboard data object not text
            MsgBox "Clipboard does not contain text - closing"
            Err.Clear
            Exit Sub
        Case Else
            ' all other errors
            msg = "Error # " & str(Err.Number) & " was generated by " _
            & Err.Source & Chr(13) & Err.Description
            Err.Clear
            MsgBox msg, vbCritical, "Error"
            Exit Sub
        End Select
    End If
    
End Sub

Function CopyToClip(sIn As String) As Boolean
    'passes the parameter string to the clipboard
    'set reference to Microsoft Forms 2.0 Object Library.
    'Clipboard cleared when launch application closes.
    
    Dim DataOut As DataObject
    
    Set DataOut = New DataObject
    
    'first pass textbox text to dataobject
    DataOut.SetText sIn
    
    'then pass dataobject text to clipboard
    DataOut.PutInClipboard
    
    'release object variable
    Set DataOut = Nothing
    
    CopyToClip = True
    
End Function

Function GetFromClip() As String
    'passes clipboard text to function name
    'If clipboard not text, an error results
    'set reference to Microsoft Forms 2.0 Object Library.
    'Clipboard cleared when launch application closes.
    
    Dim DataIn As DataObject
    
    Set DataIn = New DataObject
    
    'clipboard text to dataobject
    DataIn.GetFromClipboard
    
    'dataobject text to function string
    GetFromClip = DataIn.GetText
    
    'release object variable
    Set DataIn = Nothing
    
End Function

Sub ProjStrTo1DArr(sIn As String, vR As Variant)
    ' Input is a string of code lines that are newline separated
    ' Output is a 1D array containing the set of lines
    'vR IS ZERO BASED
    
    Dim LB As Long, UB As Long
    
    ' split clipboard string into lines
    If sIn <> "" Then
        vR = Split(sIn, vbNewLine)
        LB = LBound(vR): UB = UBound(vR)
    Else
        Exit Sub
    End If
    
End Sub

Sub ModifyComments(vA As Variant, vR As Variant, _
    Optional bOnlyAposComments As Boolean = True, _
    Optional bApostropheSpaced As Boolean = True, _
    Optional bEnable As Boolean = True)
    'Input 1D array vA; Output 1D array vR
    'Changes all comment continuation groups into
    'stand-alone comments, and modifies comments.
    'Comments are modified in ApostropheSpaces().
    'When bDisable is true, the input array is returned intact
    'vR IS BASE ZERO
    
    Dim vB As Variant, bHasMarker As Boolean
    Dim m As Long, n As Long, LB1 As Long, UB1 As Long
    Dim sL As String, sFP As String, sT As String
    Dim sCom1 As String, sCom As String, sComR As String
    Dim sR1 As String, sR2 As String, sR4 As String, sR5 As String
    Dim bOAC As Boolean, bAS As Boolean
    
    bOAC = bOnlyAposComments
    bAS = bApostropheSpaced
    
    'use a work array
    LB1 = LBound(vA): UB1 = UBound(vA)
    
    'enable or disable proc
    If bEnable = False Then
        ReDim vR(LB1 To UB1)
        vR = vA
        Exit Sub
    Else
        ReDim vB(LB1 To UB1)
        vB = vA
    End If
    
    'misc string definitions
    sR1 = Chr(82) & Chr(101) & Chr(109) & Chr(32) 'R e m + spc
    sR2 = Chr(82) & Chr(101) & Chr(109) & Chr(58) 'R e m + colon
    sR4 = Chr(39)                                 'apost
    sR5 = Chr(39) & Chr(32)                       'apost + spc
    
    'LOOP THROUGH CODE LINES
    For n = LB1 To UB1
        m = n      ' use internal loop counter
        sL = vB(m) ' get line string
        If sL = "" Then GoTo NextArrayLine
        ' test whether line string qualifies at all
        SplitStrAndComment sL, sFP, sCom
        
        ' FIND IF LINE HAS COMMENT
        If sCom <> "" Then    'line contains a comment
            
            ' FIND FIRST LINE OF CONTINUATION GROUP
            If Right$(sL, 2) = " _" Then 'found first of group
                ' remove comment's continuation markings
                sCom1 = Left$(sCom, Len(sCom) - 2)
                ' do the modifications
                ApostropheSpaces sCom1, sComR, bOAC, bAS
                vB(m) = sFP & sComR ' update with remake
                m = m + 1 'increment group counter
                ' catch exception for incomplete group
                If m > UB1 Then
                    MsgBox "Broken continuation group detected." & vbCrLf & _
                    "Please make a more complete selection."
                    Err.Raise 12347
                    Exit Sub
                Else
                    ' do other parts of continuation group
                    GoTo DoRestOfGroup
                End If
            Else
                ' HAS COMMENT BUT NO CONTINUATION
                sCom1 = sCom
                ' do the modifications
                ApostropheSpaces sCom1, sComR, bOAC, bAS
                vB(m) = sFP & sComR ' update with remake
                ' go to next array line
                GoTo NextArrayLine
            End If
        Else
            ' HAS NO COMMENT AT ALL
            GoTo NextArrayLine
        End If
        
DoRestOfGroup:
        'PROCESS SECOND GROUP LINE UP TO LAST
        Do Until m > UB1
            sL = Trim(vB(m))                ' get line string
            bHasMarker = sL Like sR1 & "*" Or sL Like sR2 & "*" _
            Or sL Like sR4 & "*" Or sL Like sR5 & "*"
            If bHasMarker = False Then
                sL = sR5 & sL               ' add comment mark
            End If
            
            ' modify and exit for line group last
            If Right$(sL, 2) <> " _" Then
                ApostropheSpaces sL, sComR, bOAC, bAS ' modify comment
                vB(m) = sComR               ' update array
                n = m - 1              ' update loop counter
                Exit Do              'group ending complete
            End If
            
            ' modify and go to next if not group last
            sL = Left$(sL, Len(sL) - 2) 'remove cont mark
            ApostropheSpaces sL, sComR, bOAC, bAS     ' modify comment
            vB(m) = sComR                  ' update array
            m = m + 1               'increment group counter
            If m > UB1 Then
                MsgBox "Broken continuation group detected." & vbCrLf & _
                "Please make a more complete selection."
                Err.Raise 12347
                Exit Sub
            End If
        Loop
        ' go to next array line
        GoTo NextArrayLine
        
NextArrayLine:
        
        ' resets
        bHasMarker = False
        sCom = "": sCom1 = "": sComR = ""
        m = 0: sL = "": sFP = "": sT = ""
    Next n
    
Transfers:
    
    ReDim vR(LB1 To UB1)
    vR = vB
    
End Sub

Function ApostropheSpaces(sIn As String, sOut As String, _
    Optional bOnlyAposComments As Boolean = True, _
    Optional bApostropheSpaced As Boolean = False) As Boolean
    ' Comment string in, modified comment string out
    ' These always start with one of two comment marker styles;
    ' r e m style or apostrophe style. Each has variations.
    ' At present, sIn broken line parts arrive apostrophied.
    
    ' ASCI values of work characters
    ' asterisk; chr(42), apostrophe; chr(39), double-quote; chr(34)
    ' R: chr(82),e: chr(101),m: chr(109),colon: chr(58)
    
    Dim sR3 As String, sL As String, bModComments As Boolean
    Dim sR1 As String, sR2 As String, sR4 As String, sR5 As String, bHasMarker As Boolean
    
    ' String definitions
    sR1 = Chr(82) & Chr(101) & Chr(109) & Chr(32) 'R e m + spc
    sR2 = Chr(82) & Chr(101) & Chr(109) & Chr(58) 'R e m + colon
    sR4 = Chr(39)                                 'apost
    sR5 = Chr(39) & Chr(32)                       'apost + spc
    
    bModComments = True ' true to apply local changes, else false to return sIn.
    
    If bModComments = False Then
        sOut = sL
        Exit Function
    End If
    
    'get line string
    sL = sIn
    
    ' Find if line fits any comment pattern
    bHasMarker = sL Like sR1 & "*" Or sL Like sR2 & "*" _
    Or sL Like sR4 & "*" Or sL Like sR5 & "*"
    If bHasMarker = True Then
        
        ' REPLACE REM STYLE WITH APOSTROPHE
        If bOnlyAposComments = True Then
            ' take first four charas of comment...
            sR3 = Left$(sL, 4)
            'if they fit r e m pattern...
            If sR3 = sR1 Or sR3 = sR2 Then
                'change the first four to an apostrophe
                sR3 = Replace(sL, sR3, sR4, 1, 1)
                sL = sR3
                sR3 = ""
            End If
        End If
        
        ' SET SPACE BEFORE APOSTROPHE
        If bApostropheSpaced = True Then
            ' take first two charas of comment...
            sR3 = Left$(sL, 2)
            'if they fit apostrophe pattern...
            If sR3 <> sR5 Then
                'change the first two to an apostrophe
                sR3 = Replace(sL, sR4, sR5, 1, 1)
                sL = sR3
                sR3 = ""
            End If
        Else
            ' bApostropheSpaced is false so remove short space.
            ' provided that no more than one existing space,
            ' replace first instance of apos + spc with just apos.
            If Left$(sL, 3) <> sR5 & Chr(32) And Left$(sL, 2) = sR5 Then
                sR3 = Replace(sL, sR5, sR4, 1, 1)
                sL = sR3
                sR3 = ""
            End If
        End If
        
    Else
        MsgBox "Pattern failure in ApostropheSpaces"
        Exit Function
    End If
    
    sOut = sL
    
    ApostropheSpaces = True
    
End Function

Function LabelLineSplit(vA As Variant, vR As Variant, Optional bEnable As Boolean = True) As Boolean
    'Input vA, 1D array with block of code lines.
    'Output vR, 1D array with label lines split.
    'Increases line count when if splitting is done
    'Takes account of line continuations in decision making.
    'When bDisable is true, the input array is returned intact
    'vR IS BASE ZERO
    
    Dim n As Long, sRC As String, vC As Variant
    Dim sLN As String, sLL As String
    Dim sL As String, sS As String, bPrevIsBroken As Boolean
    Dim LBvA As Long, UBvA As Long, UB As Long
    
    LBvA = LBound(vA): UBvA = UBound(vA)
    
    'enable or disable proc
    If bEnable = False Then
        ReDim vR(LBvA To UBvA)
        vR = vA
        Exit Function
    Else
        ReDim vR(LBvA To 0)
    End If
    
    sRC = Chr(82) & Chr(101) & Chr(109) 'r e m
    
    'Conditional transfer of lines
    For n = LBvA To UBvA
        
        'get full line string
        sL = Trim(vA(n))
        
        'exclusions
        'tranfer intact if line blank or
        'either kind of comment
        If sL = "" Or Left$(sL, 1) = Chr(39) Or _
            Left$(sL, 3) = sRC Then
            ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
            UB = UBound(vR)
            vR(UB) = Trim(sL)
            GoTo SkipThisOne
        End If
        
        ' find if it has a label
        If n = LBvA Then
            ' for first line only
            ' assume worth splitting
            SplitLineParts sL, sLN, sLL, sS
        Else ' for all lines after first
            ' test to see if prev line continued
            bPrevIsBroken = Trim(vA(n - 1)) Like "* _"
            If Not bPrevIsBroken Then 'test for label
                SplitLineParts sL, sLN, sLL, sS
            Else
                ' CONTINUATION SO TRANSFER IT INTACT
                ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
                UB = UBound(vR)
                vR(UB) = Trim(sL)
                GoTo SkipThisOne
            End If
        End If
        
        ' LABEL ACTION
        If sLL <> "" Then
            If Trim(sS) <> "" Then
                ' THERE IS A SHARED LABEL LINE TO SPLIT
                
                ReDim Preserve vR(0 To UBound(vR) + 1)
                UB = UBound(vR)
                vR(UB) = Trim(sLL) ' label onto line
                
                ReDim Preserve vR(0 To UBound(vR) + 1)
                UB = UBound(vR)
                vR(UB) = Trim(sS)
                
            Else ' ALREADY ON ITS OWN LINE
                ' so transfer label to array
                ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
                UB = UBound(vR)
                vR(UB) = Trim(sLL)
            End If
        Else   ' NOT A LABEL AT ALL SO TRANSFER IT INTACT
            ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
            UB = UBound(vR)
            vR(UB) = Trim(sL)
        End If
        
SkipThisOne:
        sL = "": sLN = "": sLL = "": sS = ""
        
    Next n
    
Transfers:
    
    ReDim vC(0 To UB - 1)
    For n = LBound(vC) To UBound(vC)
        vC(n) = vR(n + 1)
    Next n
    
    'exit as zero based array
    ReDim vR(LBound(vC) To UBound(vC))
    vR = vC
    
End Function

Function SplitStrAndComment(sIn As String, sFirstPart As String, sComment As String) As Boolean
    '==============================================================================================
    ' Returns input-less-comment in sFirstPart and any comment string in sComment.
    ' Input sIn supplies one VBA code line string, and the two parts are returned untrimmed.
    ' Has good immunity to suffering and causing corruption from comment and quote text.
    ' For no comment found, sFirstPart is sIn, and sComment is empty.
    ' Method:  Makes two runs; one search for apostrophe comments, and next for r e m comments;
    ' Removes any double quote pairs until relevant comment mark is located before any double quote.
    ' If any results are found, the one without search error has the comment that is longest.
    ' String stripped of quotes and position of comment mark are available but not returned here.
    '==============================================================================================
    
    Dim nPos As Long, sNoQuotes As String, sCmMrk As String
    Dim nPos1 As Long, nPos2 As Long, sNoQuotes1 As String
    Dim str1 As String, Str2 As String, m As Long
    Dim vM As Variant, nLA As Long, nLR As Long, sNoQuotes2 As String
    Dim q1 As Long, q2 As Long, a As Long, s1 As String, s2 As String
    Dim bQuote As Boolean, bComment As Boolean, sA As String
    Dim bACFound As Boolean, bRCFound As Boolean
    
    ' ASCI values of work characters
    ' asterisk; chr(42), apostrophe; chr(39), double-quote; chr(34)
    ' R: chr(82),e: chr(101),m: chr(109),colon: chr(58)
    
    'two runs; first for apos, then r e m comments
    vM = Array(Chr(39), Chr(82) & Chr(101) & Chr(109))
    str1 = sIn
    
    'run loop for each of two searches
    For m = 1 To 2
        'select one of two comment marks to search for
        sCmMrk = vM(m - 1) 'zero based
        
        ' check the line string patterns
        ' asterisk; chr(42), apostrophe; chr(39), double-quote; chr(34)
        bComment = str1 Like Chr(42) & sCmMrk & Chr(42) ' for an apostrophe
        bQuote = str1 Like Chr(42) & Chr(34) & Chr(42)   ' for a double quote
        
        If bComment = True And bQuote = True Then
            'has comment mark and has double quote
            ' set initial value
            q2 = 1
            Do
                ' get postion of first comment mark
                a = InStr(q2, str1 & sCmMrk, sCmMrk)
                ' get postion of first double quote
                q1 = InStr(q2, str1 & Chr(34), Chr(34))
                
                If a <= q1 Then
                    'found comment
                    sA = Right$(str1, Len(str1) - a + 1)
                    nPos = a
                    sNoQuotes = str1
                    GoTo Output
                ElseIf a > q1 Then
                    'find next quote
                    q2 = InStr(q1 + 1, str1 & Chr(34), Chr(34))
                    'if next quote is found
                    If q2 <> 0 Then
                        'remove charas from q1 to q2 inclusive
                        Str2 = Left$(str1, q1 - 1) & Right$(str1, Len(str1) - q2)
                        'set new start position for search
                        q2 = q2 + 1
                    End If
                End If
            Loop Until (a = q1)
            
        ElseIf bComment = True And bQuote = False Then
            ' has comment mark but has no double quote
            ' so return original str and comment details
            str1 = str1
            a = InStr(1, str1 & sCmMrk, sCmMrk)    ' position of first comment mark
            sA = Right$(str1, Len(str1) - a + 1) ' comment string
            nPos = a                            ' return position of comment
            sNoQuotes = str1                    ' return string without quotes
            GoTo Output
        Else
            ' no comment mark but has double quote, or
            ' no comment mark and no double quote.
            ' so return original string
            sA = ""
            nPos = 0
            sNoQuotes = str1
            GoTo Output
        End If
        
Output:
        'get details for each of two searches.
        If m = 1 Then              'for apostrophe comment search
            nLA = Len(sA) 'apos
            s1 = sA
            nPos1 = nPos
            sNoQuotes1 = sNoQuotes
        Else                       'for r e m comment search
            nLR = Len(sA) 'r e m
            s2 = sA
            nPos2 = nPos
            sNoQuotes2 = sNoQuotes
        End If
        
        'select and return details for longest comment
        If nLA > nLR Then
            bACFound = True                      'apos comment flag
            nPos = nPos1                         'position of comment
            sNoQuotes = sNoQuotes1               'de-quoted original
            sFirstPart = Left$(str1, nPos - 1)    'str before comment
            sComment = s1                        'comment string
        ElseIf nLR > nLA Then
            bRCFound = True                      'r e m comment flag
            nPos = nPos2 'de-quoted original     'position of comment
            sNoQuotes = sNoQuotes2               'de-quoted original
            sFirstPart = Left$(str1, nPos - 1)    'str before comment
            sComment = s2                        'comment string
        Else
            'no comments found
            sFirstPart = str1                     'str before comment
            sComment = ""                        'comment string
        End If
    Next m
    
    SplitStrAndComment = True
    
End Function

Sub ClpToArray(vA As Variant)
    ' loads array with lines of clipboard
    'vA IS 1D BASE ZERO ARRAY
    'sW() IS 2D BASE ONE MODULE LEVEL ARRAY
    
    Dim n As Long, m As Long, Num As Long
    Dim sLN As String, sLS As String
    Dim sLN1 As String, sLS1 As String
    Dim LBvA As Long, UBvA As Long
    Dim bPrevIsBroken As Boolean
    Dim sL As String, sLP As String
    
    'get bounds of vA
    LBvA = LBound(vA): UBvA = UBound(vA)
    
    ' count lines in vA clipboard sample
    Num = UBvA - LBvA + 1
    ' redim array
    ReDim sW(1 To 12, 1 To Num)
    
    ' load lines
    For n = LBvA To UBvA
        
        sL = Trim(vA(n))
        If n <> LBvA Then sLP = Trim(vA(n - 1))
        
        ' LINE NUMBER SPLIT DEPENDS ON CONTINUED LINES
        ' split line into line numbers and line strings
        ' find if it has a line number
        If n = LBvA Then ' for first vA line only
            ' attempt split anyway
            SplitLineNums sL, sLN1, sLS1
            sLN = sLN1: sLS = sLS1
        Else ' for all lines after first
            ' test to see if prev line continued
            bPrevIsBroken = sLP Like "* _"
            If Not bPrevIsBroken Then
                ' LOAD BOTH LINE NUMBER AND LINE STRING
                SplitLineNums sL, sLN1, sLS1
                sLN = sLN1: sLS = sLS1
            Else
                ' CONTINUATION - LOAD LINE STRING ONLY
                ' any leading number is not a line number
                sLN = "": sLS = sL
            End If
        End If
        
        m = n + 1
        ' LOAD MODULE LEVEL STRING ARRAY sW()
        sW(1, m) = m                  ' project line numbers
        sW(2, m) = sLS                ' trimmed line strings
        sW(3, m) = "other"            ' code line types
        sW(4, m) = 0                  ' structure end numbers
        sW(5, m) = 0                  ' record tab count
        sW(6, m) = ""                 ' indented strings
        sW(7, m) = ""                 ' continuations marking
        sW(8, m) = ""                 ' continuation group strings
        sW(9, m) = sLN                ' user code line numbers
        sW(10, m) = ""                ' optional output renumbering
        sW(11, m) = ""                ' marked if "Proc" or "End Proc"
        sW(12, m) = ""                ' marked if "Label"
    Next n
    
End Sub

Sub JoinBrokenLines()
    ' Identifies lines with continuation marks
    ' Joins these broken lines into one line
    ' Marks newly redundant lines as "other"
    
    Dim vA As Variant, IsContinuation As Boolean
    Dim str As String, saccum As String
    Dim n As Long, s As Long, nS As Long, nE As Long
    
    ' mark all lines that have a continuation chara
    For n = LBound(sW(), 2) To UBound(sW(), 2)
        str = sW(2, n) ' line string
        IsContinuation = str Like "* _"
        If IsContinuation Then sW(7, n) = "continuation"
    Next n
    ' mark the start and end of every continuation group
    For n = LBound(sW(), 2) To (UBound(sW(), 2) - 1)
        If n = 1 Then ' for the first line only
            If sW(7, n) = "continuation" Then sW(8, n) = "SC"
            If sW(7, n) = "continuation" And sW(7, n + 1) <> "continuation" _
            Then sW(8, n + 1) = "EC"
        Else          ' for all lines after the first
            ' find ends
            If sW(7, n) = "continuation" And sW(7, n + 1) <> "continuation" Then
                sW(8, n + 1) = "EC"
            End If
            ' find starts
            If sW(7, n) = "continuation" And sW(7, n - 1) <> "continuation" Then
                ' If sW(7, n) <> "continuation" And sW(7, n + 1) = "continuation" Then
                sW(8, n) = "SC"
            End If
        End If
    Next n
    
    ' Count continuation group starts and ends
    For n = LBound(sW(), 2) To UBound(sW(), 2)
        If sW(8, n) = "SC" Then nS = nS + 1
        If sW(8, n) = "EC" Then nE = nE + 1
    Next n
    If nS <> nE Then
        ' Error.  Means there is an incomplete continuation selection
        ' Advise, raise error and exit
        MsgBox "The selection made is not sufficiently complete." & vbCrLf & _
        "A line that is continued has parts missing." & vbCrLf & _
        "Please make a another selection."
        Err.Raise 12346
        Exit Sub
    End If
    
    ' make single strings from each continuation group
    For n = LBound(sW(), 2) To (UBound(sW(), 2) - 1)
        If sW(8, n) = "SC" Then ' group starts
            ' join strings to make one string per continuation group
            s = n
            vA = Split(CStr(sW(2, n)), "_")
            str = CStr(vA(0))
            saccum = str
            Do Until sW(8, s) = "EC"
                s = s + 1
                sW(3, s) = "other" ' mark all but first line in group as "other"
                vA = Split(CStr(sW(2, s)), "_")
                str = CStr(vA(0))
                saccum = saccum & str
            Loop
            sW(8, n) = saccum ' place at first line level in array
        End If
        str = ""
        saccum = ""
        s = 0
    Next n
    
End Sub

Sub GetLineTypes()
    ' Marks array with the indentable closed structures
    
    Dim n As Long, m As Long, str As String
    Dim bProc As Boolean
    Dim Outdents, StructureStarts, StructureEnds, bEndProc As Boolean
    Dim IsComment As Boolean, IsBlank As Boolean
    Dim IsContinuation As Boolean, IsOK As Boolean
    
    ' THESE PATTERNS DECIDE HOW STRUCTURES ARE INDENTED - (revised Oct. 2016)
    ' ================================================================================
    ' STARTS LIST - starts of structures that contain lines to indent
    
    StructureStarts = Array( _
    "Do", "Do *", "Do: *", _
    "For *", _
    "If * Then", "If * Then: *", "If * Then [!A-Z,!a-z]*", _
    "Select Case *", _
    "Type *", "Private Type *", "Public Type *", _
    "While *", _
    "With *", _
    "Sub *", "Static Sub *", "Private Sub *", "Public Sub *", "Friend Sub *", _
    "Private Static Sub *", "Public Static Sub *", "Friend Static Sub *", _
    "Function *", "Static Function *", "Private Function *", _
    "Public Function *", "Friend Function *", "Private Static Function *", _
    "Public Static Function *", "Friend Static Function, *", _
    "Property Get *", "Static Property Get *", "Private Property Get *", _
    "Public Property Get *", "Friend Property Get *", _
    "Private Static Property Get *", "Public Static Property Get *", _
    "Friend Static Property Get *", _
    "Property Let *", "Static Property Let *", "Private Property Let *", _
    "Public Property Let *", "Friend Property Let *", _
    "Private Static Property Let *", "Public Static Property Let *", _
    "Friend Static Property Let *", _
    "Property Set *", "Static Property Set *", "Private Property Set *", _
    "Public Property Set *", "Friend Property Set *", _
    "Private Static Property Set *", "Public Static Property Set *", _
    "Friend Static Property Set *")
    
    ' ENDS LIST - ends of structures that contain lines to indent
    StructureEnds = Array( _
    "Loop", "Loop *", "Loop: *", _
    "Next", "Next *", "Next: *", _
    "End If", "End If *", "End If: *", _
    "End Select", "End Select *", "End Select: *", _
    "End Type", "End Type *", "End Type: *", _
    "Wend", "Wend *", "Wend: *", _
    "End With", "End With *", "End With: *", _
    "End Sub", "End Sub *", _
    "End Function", "End Function *", _
    "End Property", "End Property *", "End Property: *")
    
    ' OUTDENTS LIST - exceptions that need re-aligned with respective start elements
    Outdents = Array( _
    "Else", "Else *", "Else: *", "Else:", _
    "ElseIf * Then", "ElseIf * Then*", _
    "Case", "Case *", _
    "Case Else", "Case Else:", "Case Else *", "Case Else:*")
    ' ================================================================================
    
    ' mark array with line types - step through each line
    For n = LBound(sW(), 2) To UBound(sW(), 2)
        str = sW(2, n)
        
        ' mark each line if a blank
        ' mark each line if a blank
        If Len(str) = 0 Then ' note blanks
            sW(3, n) = "blank"
            IsBlank = True
            GoTo RoundAgain:            ' comment
        End If
        
        ' mark each line if an own-line comment or first of folded comment parts
        IsComment = str Like Chr(39) & " *" Or str Like "'  *" ' note comment lines
        If IsComment Then
            sW(3, n) = "comment"
            GoTo RoundAgain
        End If
        
        ' mark each line if a start, end, or middle
        ' and also if a proc start or proc end
        bProc = str Like "*Sub *" Or str Like "*Function *" Or str Like "*Property *"
        bEndProc = str Like "End Sub*" Or str Like "End Function*" Or str Like "End Property*"
        
        ' mark each line if a start element
        For m = LBound(StructureStarts) To UBound(StructureStarts)
            If sW(7, n) = "continuation" And sW(8, n) <> "" Then
                IsOK = sW(8, n) Like StructureStarts(m)
            Else
                IsOK = str Like StructureStarts(m)
            End If
            
            If IsOK Then
                sW(3, n) = "start"
                If bProc Then sW(11, n) = "Proc"
                Exit For
            End If
        Next m
        If IsOK Then GoTo RoundAgain
        
        ' mark each line if an end element
        For m = LBound(StructureEnds) To UBound(StructureEnds)
            If sW(7, n) = "continuation" And sW(8, n) <> "" Then
                IsOK = sW(8, n) Like StructureEnds(m)
            Else
                IsOK = str Like StructureEnds(m)
            End If
            
            If IsOK Then
                sW(3, n) = "end"
                If bEndProc Then sW(11, n) = "End Proc"
                Exit For
            End If
        Next m
        If IsOK Then GoTo RoundAgain
        
        ' mark each line if a middle element
        For m = LBound(Outdents) To UBound(Outdents)
            If sW(7, n) = "continuation" And sW(8, n) <> "" Then
                IsOK = sW(8, n) Like Outdents(m)
            Else
                IsOK = str Like Outdents(m)
            End If
            
            If IsOK Then
                sW(3, n) = "middle"
                Exit For
            End If
        Next m
        If IsOK Then GoTo RoundAgain
        
RoundAgain:
        ' reset loop variables
        IsBlank = False
        IsComment = False
        IsContinuation = False
        IsOK = False
        bProc = False
        bEndProc = False
    Next n
    
End Sub

Sub MatchPairs()
    ' matches up the structure starts with their ends
    
    Dim n As Long, q As Long, LB As Long, UB As Long
    Dim CountStarts As Long, CountEnds As Long
    Dim IsPastEnd As Boolean, IsAPair As Boolean
    
    LB = LBound(sW(), 2): UB = UBound(sW(), 2)
    
    ' find start lines
    For n = LB To UB
        If sW(3, n) = "start" Then
            q = n    ' pass it to q for the loop
            Do
                If sW(3, q) = "start" Then
                    CountStarts = CountStarts + 1
                ElseIf sW(3, q) = "end" Then
                    CountEnds = CountEnds + 1
                End If
                ' exit condition is a pair found
                If CountStarts = CountEnds Then ' this is match-found point
                    IsAPair = True
                    Exit Do
                Else:
                    IsAPair = False
                End If
                ' increment counter while accumulating
                q = q + 1
                ' avoid access beyond upper limit of array
                If q > UB Then
                    IsPastEnd = True
                    Exit Do
                End If
            Loop
            ' evaluate the loop exit causes
            If IsAPair And IsPastEnd Then
                ' suggests that there is an unpaired structure
                MsgBox "Unpaired structure for some element: " & n
            ElseIf IsAPair And Not IsPastEnd Then
                ' found a matching structure closer for line at n
                sW(4, n) = q
            End If
        End If
        ' reset loop variables
        CountStarts = 0
        CountEnds = 0
        IsAPair = False
        IsPastEnd = False
        
    Next n
    
End Sub

Sub CheckPairs()
    ' counts structure starts and ends
    ' advises if code trivial or unpaired
    
    Dim n As Long, CountStarts As Long, CountEnds As Long
    Dim str As String, LB As Long, UB As Long, sM1 As String
    Dim sM2 As String, Reply As String
    
    LB = LBound(sW(), 2): UB = UBound(sW(), 2)
    sM2 = "Continue with indent?" & vbNewLine & _
    "Select YES to continue, or NO to exit"
    
    ' count start and end markings
    For n = 1 To UB
        str = sW(3, n)
        If str = "start" Then CountStarts = CountStarts + 1
        If str = "end" Then CountEnds = CountEnds + 1
    Next n
    
    ' check for unmatched pairs and trivial text
    If CountStarts > 0 And CountEnds > 0 Then
        ' maybe worth indenting
        If CountStarts <> CountEnds Then
            ' possible code layout error
            sM1 = "Mismatched structure pairing." & vbCrLf & _
            "This will produce some indent error."
            GoTo Notify
        Else    ' worth indenting and paired
            Exit Sub
        End If
    Else
        sM1 = "Only trivial text found" & vbCrLf & _
        "No structures were found to indent."
        GoTo Notify
    End If
    
Notify:
    Reply = MsgBox(sM1 & vbNewLine & sM2, vbYesNo + vbQuestion)
    Select Case Reply
    Case vbYes
        Exit Sub
    Case Else
        Err.Raise 12345 ' user error
        Exit Sub
    End Select
    
End Sub

Sub Indents()
    ' adds indents between starts and ends
    
    Dim n As Long, m As Long, sStr As String
    
    For n = 1 To UBound(sW(), 2)
        ' get the line string
        ' row 3 has start markings
        ' corresponding row 4 has structure end number
        sStr = sW(3, n)
        ' if string is a start element
        If sStr = "start" Then
            ' indent all between start and end
            For m = (n + 1) To sW(4, n) - 1
                ' indent one tab
                sW(5, m) = sW(5, m) + 1
            Next m
        End If
    Next n
    
End Sub

Sub Outdent()
    ' outdent keywords in middle of structures
    
    Dim n As Long, Ind As Long, UB As Long
    
    UB = UBound(sW(), 2)
    
    ' outdent loop
    For n = 1 To UB
        Ind = sW(5, n)
        ' if marked for outdent...
        If sW(3, n) = "middle" Then
            Ind = Ind - 1
            sW(5, n) = Ind
        End If
    Next n
    
End Sub

Sub SpacePlusStr(ByVal SpacesInTab As Integer, _
    Optional bKeepLineNums As Boolean = True)
    ' adds together line numbers, padding spaces, and
    ' line strings to make the indented line
    ' For bKeepLineNums true, line numbers kept as found,
    ' else false for their removal.
    
    Dim nSPT As Long, nASC As Long, nGSC As Long, nALNL As Long
    Dim p As Long, nMin As Long, nMax As Long, nTab As Long
    
    '===============================================================
    ' NOTES ABOUT SPACING FOR INDENTS AND LINE NUMBERS
    '===============================================================
    ' IN GENERAL;
    ' The general space count nGSC, the number of spaces
    ' to apply for the indent, is the prescribed number
    ' of tabs times the spaces-per-tab integer.
    
    ' BUT WITH LINE NUMBERS;
    ' For nMax < nSPT , then nASC = nGSC - nALNL
    ' For nMax >= nSPT, nASC = nGSC - nSPT + 1 + nMax - nALNL
    ' where,
    ' nMax is max line number length in the display set
    ' nSPT is the number of spaces per tab
    ' nASC is the number of actual spaces required as an indent
    ' nGSC is the general space count as described above
    ' nALNL is the number of digits in the current line number
    '================================================================
    
    ' get the min and max lengths of any line numbers
    LineNumMinMax nMax, nMin 'get min and max line numbers
    
    ' assign parameter
    nSPT = SpacesInTab
    
    ' Loop through main string array
    For p = 1 To UBound(sW(), 2)
        
        nALNL = Len(sW(9, p))
        
        ' work out the general indent to apply
        nTab = sW(5, p)
        nGSC = nSPT * nTab 'general spaces for indent
        
        ' work out actual indent, modified for line numbers
        Select Case nGSC
        Case Is > 0
            'for lines intended for indent at all
            Select Case nMax
            Case 0
                nASC = nGSC
            Case Is < nSPT
                nASC = nGSC - nALNL
            Case Is >= nSPT
                nASC = nGSC - nALNL + nMax - nSPT + 1
            End Select
            'for lines not intended for indent
        Case Is <= 0
            nASC = 0
        End Select
        
        If bKeepLineNums = True Then
            ' combine line number, padding, and line string
            sW(6, p) = sW(9, p) & Space(nASC) & sW(2, p)
        Else
            'combine padding and line string
            sW(6, p) = Space(nGSC) & sW(2, p)
        End If
    Next p
    
End Sub


Function LineNumMinMax(max As Long, min As Long) As Boolean
    'gets the minimum value of user line numbers from array
    
    Dim n As Long
    
    For n = LBound(sW, 2) To UBound(sW, 2)
        If Len(sW(9, n)) >= max Then
            max = Len(sW(9, n))
        End If
        If Len(sW(9, n)) <= min Then
            min = Len(sW(9, n))
        End If
    Next n
    
    LineNumMinMax = True
    
End Function

Sub MaxBlanks(sRet As String, Optional nMaxNumBlankLines As Long = 555)
    ' makes a single string from all code lines, indented, ready for display.
    ' and makes a single string from the original code lines as found.
    ' nMaxNumBlankLines; restricts number of contiguous blank lines.
    ' Values other than 0 or 1 leave blanks as found. (Default).
    
    Dim Str2 As String, n As Long, bOK As Boolean
    
    ' accumulate original lines as one string - not used here
    '    For p = 1 To UBound(sW(), 2)
    '        Str1 = Str1 & sW(2, p) & vbNewLine
    '    Next p
    
    ' accumulate indented lines as one string
    For n = 1 To UBound(sW(), 2)
        If n = 1 And TrimStr(CStr(sW(2, n))) = "" Then
            ' do not accum the line
            Exit For
        End If
        ' if any line string after the first is blank
        If TrimStr(CStr(sW(2, n))) = "" Then
            Select Case nMaxNumBlankLines
            Case 0
                ' do not accumulate the line
                bOK = False
            Case 1
                ' accum if only one
                If TrimStr(CStr(sW(2, n - 1))) = "" Then
                    bOK = False
                Else
                    bOK = True
                End If
            Case Else
                ' accumulate anyway
                bOK = True
            End Select
        Else
            ' if not blank - accumulate
            bOK = True
        End If
        If bOK Then
            ' accumulate line strings
            Str2 = Str2 & sW(6, n) & vbNewLine ' to display indent amounts
        End If
        bOK = False
    Next n
    
    sRet = Left(Str2, Len(Str2) - 2)
    
End Sub

Function TrimStr(ByVal str As String) As String
    ' trims leading and lagging spaces and tabs from strings
    
    Dim n As Long
    
    n = Len(str)
    
    Do ' delete tabs and spaces from left of string
        If Left(str, 1) = Chr(32) Or Left(str, 1) = Chr(9) Then
            n = Len(str)
            str = Right(str, n - 1)
        Else
            ' left is done
            Exit Do
        End If
    Loop
    Do ' delete tabs and spaces from right of string
        If Right(str, 1) = Chr(32) Or Right(str, 1) = Chr(9) Then
            n = Len(str)
            str = Left(str, n - 1)
        Else
            ' left is done
            Exit Do
        End If
    Loop
    
    TrimStr = str
    
End Function

Function SplitLineNums(sIn As String, sLN As String, sLS As String) As Boolean
    ' takes sIn and returns line number and line string parts both trimmed
    ' returns an empty string for any missing part.
    ' assumes that previous line string is not continued - handle in call proc
    
    Dim sL As String, sS As String
    Dim n As Long, sA As String, nL As Long
    Dim nLS As Long, nLN As Long, bOK As Boolean
    
    sL = Trim(sIn)
    nL = Len(sL)
    
    ' if first chara numeric...
    If IsNumeric(Left$(sL, 1)) Then
        ' separate at change to alpha
        For n = 1 To nL
            sS = Mid$(sL, n, 1)
            ' if an integer or colon...
            If Asc(sS) >= 48 And Asc(sS) <= 58 Then
                ' accumulate...
                sA = sA & sS
            Else
                ' change point found
                bOK = True
                Exit For
            End If
        Next n
        ' but for numbered blank lines...
        If Len(sA) = nL Then bOK = True
    End If
    
    ' if a line number was found...
    If bOK Then
        sLN = Trim(sA)
        nLN = Len(sA)
        sLS = Trim(Right$(sL, nL - nLN))
        nLS = Len(sLS)
    Else
        ' if no line number was found...
        sLN = "": nLN = 0: sLS = sL: nLS = nL
    End If
    
    ' MsgBox sLN: MsgBox nLN: MsgBox sLS: MsgBox nLS
    
    SplitLineNums = True
    
End Function

Function SplitLineParts(sIn As String, sLN As String, _
    sLL As String, sS As String) As Boolean
    ' sIn; input is one whole vba code line string
    ' sLN; returns line number if used, with colon if used
    ' sLL; returns label string if used, always with its colon
    ' sSS; returns split string parts if any, lead space intact
    
    Dim nPos As Long
    
    ' check for line number and labels
    If IsLineNumbered(sIn) = True Then
        sS = StrLessLineNumber(sIn, sLN) ' line number
    Else
        If IsLabelled(sIn) = True Then
            nPos = InStr(1, sIn, ":", vbTextCompare)
            sS = Right$(sIn, Len(sIn) - nPos) ' string part
            sLL = Left$(sIn, nPos)       ' line label
        Else
            sS = sIn
        End If
    End If
    
    SplitLineParts = True
    
End Function

Function IsLineNumbered(ByVal str As String) As Boolean
    ' assumes test done to exclude continuation from previous line
    ' Returns true if str starts with a vba line number format
    
    ' Line number range is 0 to 2147483647 with or without end colon
    If str Like "#*" Then
        IsLineNumbered = True
    End If
    
End Function

Function StrLessLineNumber(ByVal str As String, sLineNumber As String) As String
    ' assumes that possibility of number being a continuation is excluded.
    ' Returns with string separated from line number
    ' Includes any leading space
    ' Returns whole string if not
    
    Dim nPos As Long, sT As String
    
    ' default transfer
    StrLessLineNumber = str
    
    ' line numbers range is 0 to 2147483647
    ' if the line is some kind of line number line at all...
    If str Like "#*" Then
        
        ' specifically, if the line uses a colon separator...
        If str Like "#*: *" Then
            If InStr(str, ":") Then
                ' get colon position
                nPos = InStr(1, str, ":", vbTextCompare)
                GoTo Splits
            End If
        End If
        
        ' specifically, if the line uses a space separator
        If str Like "#* *" Then
            If InStr(str, " ") Then
                nPos = InStr(1, str, " ", vbTextCompare) - 1
                GoTo Splits
            End If
            ' default, if there is only a line number with nothing after...
        Else
            ' to return a line number but empty split string...
            nPos = Len(str)
            GoTo Splits
        End If
Splits:
        ' return string after separator
        StrLessLineNumber = Mid(str, 1 + nPos)
        sT = StrLessLineNumber
        sLineNumber = Left$(str, Len(str) - Len(sT))
        
    End If
    
End Function

Function IsLabelled(ByVal str As String) As Boolean
    ' assumes that possibility of being any kind of
    ' comment or a line number are first excluded
    ' Returns true if str starts with a vba label format
    
    Dim nPosColon As Long, nPosSpace As Long
    Dim sRC As String
    
    ' define r e m + colon
    sRC = Chr(82) & Chr(101) & Chr(109) & Chr(58)
    
    ' test for single colon exception and r e m colon exception
    If str Like ":*" Or str Like sRC & "*" Then Exit Function
    
    ' test position of first colon
    nPosColon = InStr(1, str & ":", ":")
    
    ' test position of first space
    nPosSpace = InStr(1, str & " ", " ")
    
    IsLabelled = nPosColon < nPosSpace
    
End Function

' INDENT NOTES

' =====================================================================================================
' *String Array sW() row details:
' *
' * Row 1: Integers:  Clipboard code line numbers.
' * Row 2: Strings:   Trimmed line strings.
' * Row 3: Strings:   Line type markings; one of blank, comment, start, end, or middle.
' * Row 4: Integers:  Line numbers for structure ends that match start markings.
' * Row 5: Integers:  Records sum of number of indents that are due for that line.
' * Row 6: Strings:   Line strings with their due indents added
' * Row 7: Strings:   Line type markings; continuation
' * Row 8: Strings:   Joined up continuation strings as single lines
' * Row 9: Strings:   User code line numbers
' * Row 10: Strings:  Renumbered line numbers
' * Row 11: Strings:  Proc or End Proc markings for format exceptions
' * row 12: Strings:  Marked "Label" for line label
' =====================================================================================================
' * Row 3 Markings:
' *
' * "other"           The most usual thing; the kind found within structures, eg a = 3*b
' * "start"           The start of a closed structure; eg, Sub, If, For, Select Case, etc.
' * "end"             The end of a closed structure; eg, End Sub, End If, End select, etc.
' * "middle"          The keywords that display level with starts; eg, Else, Case, etc.
' * "comment"         The line is a comment line with its own apostrophe at its start
' * "blank"           The line is completely blank
' *====================================================================================================
' * Row 7 Continuation Marks:
' *
'  * Every line that ends with a continuation mark is identified as ' continuation'  as well as the start
' * and end of each continuation grouping.
' *====================================================================================================
' * Row 8 Joined line strings:
' *
' * The start and end of each continuation grouping is marked.   These are used to construct a full
' * length line from the several parts of each grouping. Only then is there line type identification.
'  * To see the problem, a folded comment line with ' For'  or ' Do'   at the start of the second line would
'  * otherwise be taken as a ' start'  line. So too with some other line folds.
' * Joining allows better line typing
' *=====================================================================================================

See Also[edit | edit source]

External Links[edit | edit source]


Redundant Variables List

Summary[edit | edit source]

This very long code module lists an Excel project's redundant variables.

Running the top procedure checks the VBA project of ThisWorkbook, that is, the workbook in which the code is run. It produces both worksheet and user form outputs. The code is self-contained in the one module, but in addition, the user needs to make a user form called ViewVars, with a textbox in it called TextBox1. The details are not too important since the display is adjusted in code to fit the contents. However, the user form's property ShowModal should be set to False, and Multiline set to True. A testing mode of sorts can be had by setting boolean variable bUseWorkSheets in RunVarChecks to True. Be advised however, that this will clear all existing worksheets before writing to sheets one to five. To labor the point, if your intention is to not disturb the contents of project sheets one to five, then be sure that bUseWorkSheets of RunVarChecks is set to False; redundant variables will still be listed in the user form ViewVars after a few seconds of code run.

Points to Note[edit | edit source]

There are some limitations:

    • The listing can only work for code that compiles correctly; that is, sensible constructs if not necessarily working code.
    • API variable declarations and enumerations of constants are not handled. That is to say, they will not be listed even if they are redundant.
    • The module is coded to work with the VBAProject of ThisWorkbook . There is however, an optional parameter to access another workbook object for those who intend to check some other.
  • The module works with the usual VBA variable naming methods. This includes the use of public same-names, and fully expressed variable descriptions. It does so by searching for compound similars as well as their simple forms. For example, although rare, the three forms myvar, Module1.myvar, and VBProject.Module1.myvar could all be used in code for the same variable. The use of these forms allows the same variable names to be used in any module heading without conflict.
  • Several worksheet listings are made for output results and testing. The user should make sure that sheets 1 to 5 exist, since the code will not create them in this listing. The user might want to restrict or change these in the main procedure if they will conflict with other uses. A separate user form output makes use of procedure AutoLayout.
  • The user form styles might not suit everyone, but the colorings and fonts can be changed in two user-sections of the procedure AutoLayout. Bear in mind however, that the chosen font must be monospaced for a neat layout. Apart from this restriction, the layout will handle any regular font size from about 6 to 20 points, as well as the bold and italic variants. That is to say, the code will auto-adjust the userform layout and sizes to produce a useful display.
  • Procedures have not been marked as module Private. There is the remote possibility of same-name procedures being encountered when users also make use of other modules in this series. In future I will try to remember to mark them module-private if they look as though they were used elsewhere.
  • Interested parties might like to advise of any bugs. Please use only the Discussion page and I will get to them as soon as I can.

Work Method Used[edit | edit source]

General Preparation[edit | edit source]

  • The general method is to make a declared variables list then test each variable entry to see if it is used.
  • The project string contains all of the code in the project. The string is loaded into a work array line by line, and is passed in variants from process to process.
  • Procedure, module, and project name information is also added. Every code line is marked with this information.
  • Quotes and comments are removed, since they could contain any text at all, and might confuse the decision process.
  • Other confusions arise from continuation lines, so these are all joined up into single long lines prior to interpretation.
  • Shared label lines and line numbers can also cause difficulty, so labels are given lines of their own, and line numbers are separated prior to any decision process.
  • Blank lines are not needed so they are removed. Because there is a changed line count, the project work array is renumbered.
  • Each code line is marked with its residential line ranges. Each line is given the code line range for the procedure and for the module in which it resides. This data is then easily found later.

The Declared Variables[edit | edit source]

  • The declared variables list, the array vDec, contains every declared variable in the project.
  • It lists all other pertinent data about each variable. The scope of each variable is determined and added. The nominal search line ranges are also added. These are the line ranges suggested at first sight after knowing the scope of the variable. For example, a procedure level declaration would show the procedure line range, and a module-private item the module's line range.
  • The variables are marked on vDec when they are found as used. The search sequence is, all of the procedure level variables, then the module private variables, then lastly the public variables. When there are same-name variables with different scopes, this sequence is useful, in that it progressively reduces the required search ranges.
  • Every variable is checked for naming ambiguity before deciding which search method to use. Only if there is no names ambiguity can a so-called normal approach be taken; ie; searching the entire nominal line range. Otherwise, the nominal search range needs modified to avoid regions where same-name variables were already found. For example, a module variable search would not look in a procedure where a same-named variable had been both declared and used, but would check anyway if no same-name item were declared there.
  • Public and module level variables have to be checked in three names. Variables' full names can include project, module, and variable names, or just module and variable names, in addition to the better known short forms.
  • Public variables are handled a bit differently. These variables can exist in each module with the same name. There are two kinds of duplicated names possible for public variables; firstly, there is the kind where there is a public variable with the same name as a variable in any number of procedures, and secondly, there is the kind where the same name is used for a public variable in more than one module heading. In these same-name cases the use of public variables need at least the module and variable name when their use is not in the module where declared.
    • Most of the time a public variable's name is entirely unique. That is, there is no other variable in the project with the same name. In this case the use of the variable can be searched throughout the project without restriction.
    • If the public variable has no same-names in other module heads, but there are same-names in module or procedure variables, then the whole project must be searched for its use, taking into account line restrictions from modules and procedures where such same-names were already found as used.
    • If the public variable has same-name variables in more than one module heading, then the determination of variable use must be handled in two stages;
      • The entire project must be searched without restriction using both compound forms of the public variable
      • Then search in the module where the public variable is declared, taking account of any procedure restrictions that apply from same-names there.
  • After all this, any variables not marked as used can be listed as redundant.

VBA Code Module[edit | edit source]

Updated and Tested 17 Sep 2017[edit | edit source]

Modified changed word aliases to similars (15 Jan 2018).
Modified AutoLayout() to avoid wrap back in form. Label length plus 4 spaces now, not 2. (17 Sep 2017).
Added a note on need for VBA Extensibility 5.3 and tested code - working OK.(31 Dec 2016)
Modified AutoLayout() to reduce control count.(17 Nov 2016).
Modified AutoLayout() for better font choice.(16 Nov 2016).
Added simpler options for fonts in AutoLayout().(16 Nov 2016)
Modified code in dynamic arrays and added test mode switch bUseWorkSheets in RunVarChecks().(15 Nov 2016)
Removed one redundant procedure and corrected TrimStr error.(13 Nov 2016)
Corrected code call to NewPubRange() in MarkPubVarUse(). Parameter lines now whole project.(8 Nov 2016)
Changes made to user form display procedures. (7 Nov 2016)

Option Explicit
Option Base 1

Sub TestVars()
    'Be sure to set a reference to Visual Basic for Applications Extensibility 5.3    
    Dim vWB As Variant
    
    'set reference to a workbook
    'in the current workbooks collection
    Set vWB = ThisWorkbook
    
    RunVarChecks vWB

End Sub

Sub RunVarChecks(Optional vWB As Variant)
    'runs a redundant variable check on a workbook's code project
    'If no workbook supplied in vWB defaults to this workbook.
    'Exclusions: "Declared", "Type" and "Const" declarations.
    'CLEARS ALL WORKSHEETS AND REWRITES TO SHEETS 1 TO 5
    'WHEN bUseWorkSheets IS TRUE
    
    Dim sht As Worksheet, vDec As Variant, vX As Variant, vAB As Variant
    Dim c As Long, n As Long, UDec2 As Long, sLN As Long, vT As Variant
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    Dim vJ As Variant, vK As Variant, vL As Variant, vM As Variant
    Dim vP As Variant, vR As Variant, vS As Variant, vN As Variant
    Dim vU As Variant, vV As Variant, vW As Variant, vDisp As Variant
    Dim sLS As String, sPN As String, sMN As String, sProc As String
    Dim sVScope As String, sP As String, bOneToFind As Boolean
    Dim bProcNamed As Boolean, bNotFirst As Boolean, Upper As Long
    Dim bUseWorkSheets As Boolean
    Dim Uform As UserForm
    
    '==================================================================
    bUseWorkSheets = False  'when true, overwrites all worksheets
    '                        and displays test data in sheets 1 to 5,
    '                        else when false, userform output only.
    '==================================================================
    
    'decide whether to use parameter wb or this one
    If IsMissing(vWB) Then
        Set vWB = ThisWorkbook
    End If
     
    'clear sheets - clears all sheets
    'and unloads open userforms
    For Each Uform In VBA.UserForms
        Unload Uform
        Exit For
    Next Uform
    If bUseWorkSheets = True Then
       For Each sht In ThisWorkbook.Worksheets
           sht.Activate
           sht.Range("A1:Z65536").ClearContents
       Next sht
    End If

'PREPARE THE PROJECT ARRAY
     
     sP = LoadProject(vP, vWB)     '0 view original source data on sheet 1
     
     '=========================================================================
     If bUseWorkSheets = True Then PrintArrayToSheet vP, "Sheet1" 'raw project
     '=========================================================================
     TrimStr vP, vS             '1 remove end spc and tabs-not newlines
     JoinBrokenLines vS, vW     '2 rejoin broken lines-leaves blank lines
     RemoveApostFmQuotes vW, vJ '3
     RemoveAllComments vJ, vL   '4 remove all comments-leaves blank lines
     RemoveBlankLines vL, vK    '5 remove all blank lines-reduces line count
     RemoveQuotes vK, vM        '6 remove all double quotes and their contents
     SplitAtColons vM, vV       '7 make separate statement lines split at colons
     NumbersToRow vV, vU, 6     '8 new line count row 6; originals still in row 1
                                  'DO NOT RENUMBER LINES BEYOND MarkLineRanges()
     MarkLineRanges vU, vR      '9 mark array with line ranges for search later
     '=========================================================================
     If bUseWorkSheets = True Then PrintArrayToSheet vR, "Sheet2" 'mod project
     '=========================================================================
     
     'get bounds of modified project line array
     Lb1 = LBound(vR, 1): Ub1 = UBound(vR, 1)
     Lb2 = LBound(vR, 2): Ub2 = UBound(vR, 2)
     
     'redim of declared variables array
     ReDim vDec(1 To 12, 0 To 0)
     ReDim vDisp(1 To 4, 0 To 0)
     
'MAKE THE DECLARED VARIABLES ARRAY
     
     'get one line of project array at a time
     'if a declaration line, parse it and extract variables
     'to build the declared variables array vDec
     For c = Lb2 To Ub2
        DoEvents
        'get one line of data from array
        sLN = CStr(vR(1, c))     'original line number
        sPN = vR(3, c)           'project name
        sMN = vR(4, c)           'module name
        sProc = vR(5, c)         'procedure name
        sLS = vR(8, c)           'joined line string
        
        'get declared variables from the line string
        If sProc <> "" Then bProcNamed = True Else bProcNamed = False
        GetDeclaredVariables sLS, bProcNamed, sVScope, vM
        If sVScope <> "" Then
            'load declared variables array with dec vars for one line
            If UBound(vM) >= 1 Then 'it is a declaration line
                'mark the source array string as a declaration line
                vR(13, c) = "Declaration"
                'transfer found line variables to vDec
                For n = LBound(vM) To UBound(vM)
                    ReDim Preserve vDec(1 To 12, 1 To UBound(vDec, 2) + 1)
                    UDec2 = UBound(vDec, 2)                     'vDec line number
                    vDec(1, UDec2) = vM(n)                      'Declared variable
                    vDec(2, UDec2) = sPN                        'Project name
                    vDec(3, UDec2) = sMN                        'Module name
                    vDec(4, UDec2) = sProc                      'Procedure name
                    vDec(5, UDec2) = sVScope                    'Scope of variable
                    vDec(6, UDec2) = StartOfRng(vR, sVScope, c) 'Nominal line search start
                    vDec(7, UDec2) = EndOfRng(vR, sVScope, c)   'Nominal line search end
                    vDec(8, UDec2) = ""                         'Used marking
                    vDec(9, UDec2) = sLN                        'Original line number
                    vDec(10, UDec2) = ""                        'Use checked marker
                    vDec(11, UDec2) = vR(9, c)                  'Module start line number
                    vDec(12, UDec2) = vR(10, c)                 'Module end line number
                Next n
            End If
        End If
     Next c
     
     EmptyTheDecLines vR, vT     '10 replaces line string with empty string-no change line count
     
'DISPLAY CONDITIONED PROJECT ARRAY ON WORKSHEET
     
     '=========================================================================
     If bUseWorkSheets = True Then PrintArrayToSheet vT, "Sheet3" 'mod project
     '=========================================================================

'NOTES
     'AT THIS POINT vT CONTAINS THE PROJECT LINES SOURCE TO SEARCH FOR USED VARIABLES.
     'vT WILL ALSO BE USED TO SEARCH FOR THE USE OF DECLARED VARIABLES LISTED IN vDec.
     'vDec LISTS THE INITIAL LINE NUMBERS RANGE FOR USE-SEARCH, THOUGH THESE ARE LATER MODIFIED.
     'The use-search sequence is all procprivate, all modprivate, then all varpublic.
     'All declared variables marked as used at one stage need not have their search ranges
     'searched again at the next. Eg: Same-name procprivate-used could never be Modprivate-used also.
     'Same-name varpublic variables could only apply as used where neither procprivate or modprivate.
     'Nominally assigned searched ranges are modified after each stage to narrow the search line ranges
     'for the next stage.
     'Same-name public variables in each of several module heads are not yet handled.
     
'MARK THE DECLARED VARIABLES ARRAY WITH USE STATUS
     
     'FIRST - MARK USE OF PROCPRIVATE vDec ITEMS
     MarkProcVarUse vDec, vT, vN
     vDec = vN
     MarkModVarUse vDec, vT, vAB
     vDec = vAB
     MarkPubVarUse vDec, vT, vX
     vDec = vX
   
     
'DISPLAY DECLARED VARIABLES ARRAY ON WORKSHEET
     
     '=======================================================================================
     If bUseWorkSheets = True Then PrintArrayToSheet vDec, "Sheet4" 'declared variables list
     '=======================================================================================
     
'LOAD REDUNDANT VARIABLES RESULTS ARRAY
        
        For n = LBound(vDec, 2) To UBound(vDec, 2)
            ' check whether or not marked used
            If vDec(8, n) = "" Then
                'unused variable so transfer details
                If bNotFirst = True Then
                    'not first data transfer
                    'so increment array before transfer
                    Upper = UBound(vDisp, 2) + 1
                    ReDim Preserve vDisp(1 To 4, 1 To Upper)
                Else
                    'is first data transfer
                    'so just use first element
                    ReDim vDisp(1 To 4, 1 To 1)
                    Upper = UBound(vDisp, 2)
                    bNotFirst = True
                End If
                ' transfer variable details to display array
                vDisp(1, Upper) = vDec(1, n) 'variable name
                vDisp(2, Upper) = vDec(4, n) 'procedure name
                vDisp(3, Upper) = vDec(3, n) 'module name
                vDisp(4, Upper) = vDec(2, n) 'project name
            End If
        Next n
        
        ' report if none found
        If UBound(vDisp, 2) = 0 Then
            MsgBox "No redundant variables found for display"
            Exit Sub
        End If
     
'DISPLAY REDUNDANT VARIABLES RESULTS ON WORKSHEET
     
     '=========================================================================================
     If bUseWorkSheets = True Then PrintArrayToSheet vDisp, "Sheet5" 'redundant variables list
     '=========================================================================================
     
'DISPLAY REDUNDANT VARIABLES RESULTS ON USERFORM
     
     AutoLayout vDisp, 1

End Sub

Function LoadProject(vR As Variant, wb As Variant) As String
    ' Loads local array with parameter workbook's
    ' whole VBA project string line by line,
    ' and other details, and returns in array vR.
    ' Whole project string can be found in LoadProject.
    ' Needs set reference to Microsoft VBA Extensibility 5.5
    
        '==============================================
        '     Local String Array sW() Row Details.
        '       Each line record in one column
        '==============================================
        'Row 1:   Orig proj line number
        'Row 2:   Orig line string working
        'Row 3:   Project name
        'Row 4:   Module name
        'Row 5:   Procedure name
        'Row 6:   Reduced proj line number
        'Row 7:   Temp use for continuation marking
        'Row 8:   Rejoined versions of lines
        'Row 9:   Module start number
        'Row 10:  Module end number
        'Row 11:  Procedure start number
        'Row 12:  Procedure end number
        'Row 13:  n/a
        'Row 14:  n/a
        '==============================================
    
    Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
    Dim VBMod As VBIDE.CodeModule, ProcKind As VBIDE.vbext_ProcKind
    Dim sMod As String, sProj As String, sLine As String
    Dim nLines As Long, n As Long, nC As Long, sW() As String
    Dim Ub2 As Long
    
    'redim dynamic array
    Erase sW()
    ReDim sW(1 To 14, 1 To 1)
    
    'get ref to parameter workbook
    Set VBProj = wb.VBProject

    'loop through VBComponents collection
    For Each VBComp In VBProj.VBComponents
        Set VBMod = VBComp.CodeModule
        nLines = VBMod.CountOfLines
        sProj = sProj & VBMod.Lines(1, nLines)          'project string
        sMod = VBMod.Lines(1, nLines)                   'module string
        If nLines <> 0 Then
            With VBMod
                For n = 1 To nLines
                    DoEvents
                    sLine = Trim(.Lines(n, 1))          'line string
                    'Debug.Print sLine
                    'redim array for each record
                    ReDim Preserve sW(1 To 14, 1 To nC + n)
                    Ub2 = UBound(sW, 2)
                    'load lines of each module into array
                    sW(1, Ub2) = CStr(Ub2)                'orig proj line number
                    sW(2, Ub2) = sLine                    'raw line string working
                    sW(3, Ub2) = VBProj.Name              'project name
                    sW(4, Ub2) = VBMod.Name               'module name
                    sW(5, Ub2) = .ProcOfLine(n, ProcKind) 'procedure name
                    sW(6, Ub2) = ""                       'reduced proj line number
                    sW(7, Ub2) = ""                       'continuation mark working
                    sW(8, Ub2) = ""                       'long joined-up broken lines
                    sW(9, Ub2) = ""                       'Module start number
                    sW(10, Ub2) = ""                      'Module end number
                    sW(11, Ub2) = ""                      'Procedure start number
                    sW(12, Ub2) = ""                      'Procedure end number
                    sW(13, Ub2) = ""                      'n/a
                    sW(14, Ub2) = ""                      'n/a
                Next n
            End With
        End If
        nC = nC + nLines 'increment for next redim
        
    Next VBComp
    
    'Debug.Print sproj
    LoadProject = sProj
    vR = sW()
    
    Set VBProj = Nothing: Set VBComp = Nothing
    Set VBMod = Nothing
   
End Function

Private Sub TrimStr(vA As Variant, vR As Variant)
    'trims leading and lagging spaces and tabs
    'from all input array vA code lines
    'Returns array in vR
    
    Dim n As Long, c As Long
    Dim vW As Variant, str As String
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    vW = vA
    
    'modify the line strings of the array
    For c = Lb2 To Ub2
        'get the line string
        str = vW(2, c)
        n = Len(str)
        
        Do 'delete tabs and spaces from left of string
            If Left(str, 1) = Chr(32) Or Left(str, 1) = Chr(9) Then
                n = Len(str)
                str = Right(str, n - 1)
            Else
                'left is done
                Exit Do
            End If
        Loop
        Do 'delete tabs and spaces from right of string
            If Right(str, 1) = Chr(32) Or Right(str, 1) = Chr(9) Then
                n = Len(str)
                str = Left(str, n - 1)
            Else
                'left is done
                Exit Do
            End If
        Loop
        
        'pass back the mod string
        vW(2, c) = str
    Next c
    
    'transfers
    vR = vW
    
End Sub

Sub JoinBrokenLines(vP As Variant, vR As Variant)
    'Identifies and joins lines with continuation marks
    'Whole lines placed into row 8
    'Marks old broken bits as newlines.
    'Newlines are removed later in RemoveBlankLines().
    
    Dim vA As Variant, vW As Variant, IsContinuation As Boolean
    Dim str As String, sAccum As String, n As Long, s As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vP, 1): Ub1 = UBound(vP, 1)
    Lb2 = LBound(vP, 2): Ub2 = UBound(vP, 2)
    
    ReDim vW(Lb1 To Ub1, Lb2 To Ub2)
    
    'pass to work variable
    vW = vP
    
    'mark all lines that have a continuation chara
    For n = LBound(vW, 2) To UBound(vW, 2)
        str = vW(2, n) 'line string
        IsContinuation = str Like "* _"
        If IsContinuation Then vW(7, n) = "continuation"
    Next n
    'mark the start and end of every continuation group
    For n = LBound(vW, 2) To (UBound(vW, 2) - 1)
        If n = 1 Then 'for the first line only
            If vW(7, n) = "continuation" Then vW(8, n) = "SC"
            If vW(7, n) = "continuation" And vW(7, n + 1) <> "continuation" _
            Then vW(8, n + 1) = "EC"
        Else          'for all lines after the first
            'find ends
            If vW(7, n) = "continuation" And vW(7, n + 1) <> "continuation" Then
                vW(8, n + 1) = "EC"
            End If
            'find starts
            If vW(7, n) = "continuation" And vW(7, n - 1) <> "continuation" Then
                'If vw(7, n) <> "continuation" And vw(7, n + 1) = "continuation" Then
                vW(8, n) = "SC"
            End If
        End If
    Next n
    'make single strings from each continuation group
    For n = LBound(vW, 2) To (UBound(vW, 2) - 1)
        If vW(8, n) = "SC" Then 'group starts
            'join strings to make one string per continuation group
            s = n
            vA = Split(CStr(vW(2, n)), "_")
            str = CStr(vA(0))
            sAccum = str
            Do Until vW(8, s) = "EC"
                s = s + 1
                'handle other continued parts
                vA = Split(CStr(vW(2, s)), "_")
                str = CStr(vA(0))
                sAccum = sAccum & str
                vW(2, s) = Replace(vW(2, s), vW(2, s), vbNewLine)
            Loop
            vW(8, n) = sAccum 'place at first line level in array
        End If
        str = ""
        sAccum = ""
        s = 0
    Next n
    
    'write remaining strings into row 8 for consistency
    'all string parsing and other work now uses row 8
    For n = Lb2 To Ub2
        If vW(8, n) = "" Or vW(8, n) = "SC" Or vW(8, n) = "EC" Then
        vW(8, n) = Trim(vW(2, n))
        End If
    Next n
    
    'transfers
    vR = vW

End Sub

Sub RemoveApostFmQuotes(vB As Variant, vR As Variant)
    'returns array vB as vR with apostrophies removed
    'from between sets of double quotes,
    'Remainder of quote and double quotes themselves left intact.
    'for example s = "Dim eyes (Bob's)" becomes s = "Dim eyes (Bobs)"
            
    Dim str As String, str1 As String, vA As Variant, c As Long
    Dim n As Long, m As Long, bUnpaired As Boolean, r As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vB, 1): Ub1 = UBound(vB, 1)
    Lb2 = LBound(vB, 2): Ub2 = UBound(vB, 2)

    ReDim vR(Lb1 To Ub1, Lb2 To Ub2)

    'set up loop to get one line at a time
    
    For c = Lb2 To Ub2
        str = vB(8, c)
        
        'split string at double quotes
        If str <> "" Then
            vA = Split(str, """")
        Else
            'empty string
            str1 = str
            GoTo Transfers
        End If
        
        'recombine the splits
        m = UBound(vA) - LBound(vA)
        'as long as even num of quote pairs
        If m Mod 2 = 0 Then
            For n = LBound(vA) To UBound(vA)
               If n Mod 2 = 0 Then 'even elements
                   str1 = str1 & vA(n)
               Else
                   'odd elements
                   'apostrophies removed
                   str1 = str1 & Replace(vA(n), "'", "")
               End If
            Next n
        Else
            'unpaired double quotes detected
            bUnpaired = True
        End If

Transfers:  'transfer one row only
        For r = Lb1 To Ub1
            vR(r, c) = vB(r, c)
        Next r
        'if all pairs matched
        If bUnpaired = False Then
            vR(8, c) = str1
        Else
            'exit loop with str
        End If
        str1 = "" 'reset accumulator
        bUnpaired = False
    Next c

End Sub

Sub RemoveAllComments(vA As Variant, vR As Variant)
    'Removes all comments from vA row 8 line strings
    'Includes comments front, middle and end so
    'apostrophed text in double quotes would result
    'in a false line split if not first removed.
        
    Dim bAny As Boolean, bStart As Boolean, bEnd As Boolean
    Dim n As Long, m As Long, c As Long, r As Long
    Dim bincluded As Boolean, l As Long, str As String
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    ReDim vR(Lb1 To Ub1, 0 To 0)
    
    For c = Lb2 To Ub2
        str = vA(8, c)
        'detect any instance of a comment mark
        bAny = str Like "*'*"
        If Not bAny Then
            'go for row INCLUSION action
            'with original str
            bincluded = True
            GoTo Transfers
        Else
            'comment front, 'middle, or 'end
        End If
        'find whether or not has comment at front
        bStart = str Like "'*"
        If bStart Then
            'go for row EXCLUSION action
            'do not include row at all
            bincluded = False
            GoTo Transfers
        Else
            'might still have comment at end
        End If
        'find whether or not has comment at end
        bEnd = str Like "* '*"
        If bEnd Then
            'remove comment at end
            l = Len(str)
            For n = 1 To l
                If Mid(str, n, 2) = " '" Then
                    str = Trim(Left(str, n - 1))
                    'go for row INCLUSION action
                    'with modified str
                    bincluded = True
                    GoTo Transfers
                End If
            Next n
        End If
        'decide on how to do the default thing
Transfers:
        If bincluded = True Then
            'include the current row
            m = m + 1
            ReDim Preserve vR(Lb1 To Ub1, 1 To m)
            For r = Lb1 To Ub1
                vR(r, m) = vA(r, c)
            Next r
            vR(8, m) = str
        Else
            'do not include the current row
        End If
    Next c

End Sub

Sub RemoveBlankLines(vA As Variant, vR As Variant)
    'removes all blank lines from proj array vA
    'and returns with modified array in vR
    'Changes line count
    
    Dim vM As Variant, bNotFirst As Boolean
    Dim c As Long, r As Long, Upper As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    ReDim vM(Lb1 To Ub1, 1 To 1)
    
    For c = Lb2 To Ub2
        If vA(8, c) <> "" And vA(8, c) <> vbNewLine Then
            
            If bNotFirst = True Then
                'not first data transfer
                'so increment array before transfer
                Upper = UBound(vM, 2) + 1
                ReDim Preserve vM(Lb1 To Ub1, 1 To Upper)
            Else
                'is first data transfer
                'so just use first element
                Upper = UBound(vM, 2)
                bNotFirst = True
            End If
    
            'transfer data
            For r = Lb1 To Ub1
                vM(r, Upper) = vA(r, c)
            Next r
        End If
    Next c
    vR = vM
    
End Sub

Sub RemoveQuotes(vB As Variant, vR As Variant)
    'returns array vB as vR with all text between pairs
    'of double quotes removed, and double quotes themselves
    'for example s = "Dim eyes" becomes s =
    'A failed quotes pairing returns original string.
        
    Dim str As String, str1 As String, vA As Variant, c As Long
    Dim n As Long, m As Long, bUnpaired As Boolean, r As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vB, 1): Ub1 = UBound(vB, 1)
    Lb2 = LBound(vB, 2): Ub2 = UBound(vB, 2)

    ReDim vR(Lb1 To Ub1, Lb2 To Ub2)

    'set up loop to get one line at a time
    
    For c = Lb2 To Ub2
        str = vB(8, c)
        
        'split string at double quotes
        If str <> "" Then
            vA = Split(str, """")
        Else
            'empty string
            str1 = str
            GoTo Transfers
        End If
        
        'overwrite odd elements to be empty strings
        m = UBound(vA) - LBound(vA)
        'as long as even num of quote pairs
        If m Mod 2 = 0 Then
            For n = LBound(vA) To UBound(vA)
               'accum even elements
               If n Mod 2 = 0 Then
                   str1 = str1 & vA(n)
               End If
            Next n
        Else
            'unpaired double quotes detected
            bUnpaired = True
        End If

Transfers:  'transfer one row only
        For r = Lb1 To Ub1
            vR(r, c) = vB(r, c)
        Next r
        'if all pairs matched
        If bUnpaired = False Then
            vR(8, c) = str1
        Else
            'exit loop with str
        End If
        str1 = "" 'reset accumulator
        bUnpaired = False
    Next c

End Sub

Sub SplitAtColons(vA As Variant, vR As Variant)
    'Because statements and other lines can be placed
    'in line and separated by colons, they must be split.
    'Splits such into separate lines and increases line count,
    'Input array in vA and returns in vR.
    'Note: The space after colon is distinct from named arguments
    'that have no space after the colon.
        
    Dim vF As Variant, vW As Variant
    Dim n As Long, sLine As String, bNotFirst As Boolean
    Dim Elem As Variant, m As Long, Upper As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    ReDim vW(Lb1 To Ub1, Lb2 To Ub2)
    ReDim vR(Lb1 To Ub1, 1 To 1)
    
    'pass to work variable
    vW = vA
    For n = Lb2 To Ub2 'for each line existing
        'get line string
        sLine = Trim(vW(8, n))
            'decide if has colons
            'do the split
            vF = Split(sLine, ": ")
            'does it contain colons?
            If UBound(vF) >= 1 Then 'there were non-arg colons
                'make a new line in return array for each elem
                For Each Elem In vF
                    Elem = Trim(CStr(Elem))
                    If Elem <> "" Then
                        If bNotFirst = True Then
                            'not first data transfer
                            'so increment array before transfer
                            Upper = UBound(vR, 2) + 1
                            ReDim Preserve vR(Lb1 To Ub1, 1 To Upper)
                        Else
                            'is first data transfer
                            'so just use first element
                            Upper = UBound(vR, 2)
                            bNotFirst = True
                        End If
                        'transfer line of vW to vR
                        For m = 1 To 8
                            vR(m, Upper) = vW(m, n)
                        Next m
                        vR(8, Upper) = Elem 'overwrite line string
                    End If
                Next Elem
            Else
                'no colons - redim array and normal line transfer
                If bNotFirst = True Then
                    'not first data transfer
                    'so increment array before transfer
                    Upper = UBound(vR, 2) + 1
                    ReDim Preserve vR(Lb1 To Ub1, 1 To Upper)
                Else
                    'is first data transfer
                    'so just use first element
                    Upper = UBound(vR, 2)
                    bNotFirst = True
                End If
                
                ReDim Preserve vR(Lb1 To Ub1, 1 To Upper)
                'transfer line of vW to vR
                For m = Lb1 To Ub1
                    vR(m, Upper) = vW(m, n)
                Next m
            End If
    Next n

End Sub

Sub NumbersToRow(vA As Variant, vR As Variant, Optional nRow As Long = 6)
    'adds renumbering of current array lines to row 6.
    'and returns vA array in vR. Original numbers still in row 1.
    'Optional row number defaults to 6
        
    Dim n As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
        
    ReDim vR(Lb1 To Ub1, Lb2 To Ub2)

    For n = Lb2 To Ub2
        vA(nRow, n) = n
    Next n

    vR = vA

End Sub

Sub MarkLineRanges(vA As Variant, vR As Variant)
    'Input array in vA, returned in vR with markings.
    'Adds any module and procedure line ranges
    'that may apply, for every line of vA.  These figures
    'will be used for the nominal search line ranges.
        
    Dim nS As Long, sS As String, vW As Variant, n As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long

    'get bounds of project array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)

    ReDim vR(Lb1 To Ub1, Lb2 To Ub2)

    vW = vA
        
    'MODULE START RANGE
    'get the start point values in place
    sS = Trim(vW(4, 1)) 'get first module name
    nS = CLng(Trim(vW(6, 1))) 'get line number for first module entry
    vW(9, Lb2) = nS
    
    For n = Lb2 To Ub2 - 1
    'If vW(5, n) = "" Then 'it is a module entry
        'count same items
        If vW(4, n) = vW(4, n + 1) Then
            'still same module name
            'so mark start value same
            vW(9, n + 1) = nS
        Else
            'n+1 when not same
            sS = vW(4, n + 1)
            vW(9, n) = nS
            nS = vW(6, n + 1)
            vW(9, n + 1) = nS
        End If
    Next n
    
    'MODULE END RANGE
    sS = Trim(vW(4, Ub2)) 'get last module name
    nS = CLng(Trim(vW(6, Ub2))) 'get line number for first module entry
    vW(10, Ub2) = nS
    For n = Ub2 To (Lb2 + 1) Step -1
    'If vW(5, n) = "" Then 'it is a module entry
        'count same items
        If vW(4, n) = vW(4, n - 1) Then
            'still same module name
            'so mark start value same
            vW(10, n - 1) = nS
        Else
            'n+1 when not same
            sS = vW(4, n - 1)
            vW(10, n) = nS
            nS = vW(6, n - 1)
            vW(10, n - 1) = nS
        End If
    Next n

    'PROCEDURE START RANGE
    'get the start point values in place
    sS = Trim(vW(5, 1)) 'get first procedure name
    nS = CLng(Trim(vW(6, 1))) 'get line number proc entry
    vW(11, Lb2) = nS
    For n = Lb2 To Ub2 - 1
    'If vW(5, n) = "" Then 'it is a module entry
        'count same items
        If vW(5, n) = vW(5, n + 1) Then
            'still same module name
            'so mark start value same
            vW(11, n + 1) = nS
        Else
            'n+1 when not same
            sS = vW(5, n + 1)
            vW(11, n) = nS
            nS = vW(6, n + 1)
            vW(11, n + 1) = nS
        End If
    Next n
    
    'PROCEDURE END RANGE
    sS = Trim(vW(5, Ub2)) 'get last proc name
    nS = CLng(Trim(vW(6, Ub2))) 'get line number proc entry
    vW(12, Ub2) = nS
    For n = Ub2 To (Lb2 + 1) Step -1
    'If vW(5, n) = "" Then 'it is a module entry
        'count same items
        If vW(5, n) = vW(5, n - 1) Then
            'still same module name
            'so mark start value same
            vW(12, n - 1) = nS
        Else
            'n+1 when not same
            sS = vW(5, n - 1)
            vW(12, n) = nS
            nS = vW(6, n - 1)
            vW(12, n - 1) = nS
        End If
    Next n
    
    'ADD PUBLIC VARIABLE LINE RANGES
    'public variable line ranges need not be marked
    'since the whole project line range applies
    
    'transfers
    vR = vW

End Sub

Sub GetDeclaredVariables(sLine As String, bProcName As Boolean, sScope As String, vRet As Variant)
    'Returns an array of declared variables in line string sLine.
    'This is used to build the declared variables array (vDec) in RunVarChecks().
    'bProcName input is true if sLine project record lists a procedure name, else false.
    'sScope outputs scope of line declarations returned in vRet.
    'sScope values are "PROCPRIVATE", "DECLARED", "MODPRIVATE", or "VARPUBLIC"
    '=========================================================================
    'sScope RETURNS:
    '"PROCPRIVATE";  returned if declaration is private to a procedure
    '"MODPRIVATE";   returned if declaration is private to a module
    '"VARPUBLIC";    returned if declaration is public
    '"DECLARED";     returned if declared with keyword "Declared" in heading
    '=========================================================================
    
    Dim IsDim As Boolean, nL As Long, vF As Variant
    Dim Elem As Variant, vS As Variant, vT As Variant
    Dim bPrivate As Boolean, bPublic As Boolean, bStatic As Boolean
    Dim bPrivPubStat As Boolean, bDeclare As Boolean, bType As Boolean
    Dim bSub As Boolean, bFunc As Boolean, bConst As Boolean
    Dim n As Long, Upper As Long, bNotFirst As Boolean

'   '----------------------------------------------------------------------------
'   Handle exclusions: lines that contain any of the declaration keywords;
'   "Declare", "Const", and "Type"
'   '----------------------------------------------------------------------------
    bDeclare = sLine Like "* Declare *" Or sLine Like "Declare *"
    bConst = sLine Like "* Const *" Or sLine Like "Const *"
    bType = sLine Like "* Type *" Or sLine Like "Type *"
    If bDeclare Or bConst Or bType Then
        GoTo DefaultTransfer
    End If
'----------------------------------------------------------------------------
'   Then, check declarations that were made with the "Dim" statement,
'   at private module and at procedure level.
'----------------------------------------------------------------------------
    'sLine = "Dim IsDim As Boolean, nL As Long, vF(1 to4,4 to 6,7 to 10) As Variant"
    sLine = Trim(sLine)
    ReDim vT(0 To 0)
    
    IsDim = sLine Like "Dim *"
    'could be proc or module level
    If IsDim Then
        nL = Len(sLine)
        sLine = Right(sLine, nL - 4)
        
        'do the first split
        sLine = RemoveVarArgs(sLine)
        vF = Split(sLine, ",")
        
        'do the second split
        For Each Elem In vF
            Elem = Trim(CStr(Elem))
            If Elem <> "" Then
                vS = Split(Elem, " ")
                'Optional might still preceed var name
                For n = LBound(vS) To UBound(vS)
                    If vS(n) <> "Optional" Then
                        'redim the array
                        If bNotFirst = True Then
                            'not first data transfer
                            'so increment array before transfer
                            Upper = UBound(vT) + 1
                            ReDim Preserve vT(LBound(vT) To Upper)
                        Else
                            'is first data transfer
                            'so just use first element
                            ReDim vT(1 To 1)
                            Upper = UBound(vT)
                            bNotFirst = True
                        End If
                        vT(Upper) = vS(n)
                        Exit For
                    End If
                Next n
            End If
        Next Elem
        
        'return results
            If UBound(vT, 1) >= 1 Then
                If bProcName = True Then
Transfer1:          sScope = "PROCPRIVATE"
                Else
                    sScope = "MODPRIVATE"
                End If
                    vRet = vT
                Exit Sub 'Function
            End If
        
    Else: 'not a dim item so...
        GoTo CheckProcLines
    End If

CheckProcLines:
'---------------------------------------------------------------------------------
'   Check declarations that were made in public and private procedure definitions.
'   Procedure definitions made in the module heading with declare are excluded.
'---------------------------------------------------------------------------------
    bSub = sLine Like "*Sub *(*[A-z]*)*"
    bFunc = sLine Like "*Function *(*[A-z]*)*"
    If bSub Or bFunc Then
        'obtain contents of first set round brackets
        sLine = GetProcArgs(sLine)
        'obtain vars without args
        sLine = RemoveVarArgs(sLine)
        'first split
        vF = Split(sLine, ",")
        For Each Elem In vF
            Elem = Trim(CStr(Elem))
            If Elem <> "" Then
                'second split
                vS = Split(Elem, " ")
                'any of Optional, ByVal, ByRef, or ParamArray might preceed var name
                For n = LBound(vS) To UBound(vS)
                    If vS(n) <> "Declare" And vS(n) <> "Optional" And vS(n) <> "ByVal" And _
                        vS(n) <> "ByRef" And vS(n) <> "ParamArray" Then
                        'redim the array
                        If bNotFirst = True Then
                            'not first data transfer
                            'so increment array before transfer
                            Upper = UBound(vT) + 1
                            ReDim Preserve vT(LBound(vT) To Upper)
                        Else
                            'is first data transfer
                            'so just use first element
                            ReDim vT(1 To 1)
                            Upper = UBound(vT)
                            bNotFirst = True
                        End If
                        vT(Upper) = vS(n)
                        Exit For
                    End If
                Next n
            End If
        Next Elem
                
        'return results if any found in section
        If UBound(vT) >= 1 Then
            If bProcName = True Then
Transfers2:     sScope = "PROCPRIVATE"
            Else
                'exits with empty sScope
                sScope = ""
            End If
                vRet = vT
            Exit Sub
        End If
               
    Else 'not a dec proc line so...
        GoTo OtherVarDecs
    End If

OtherVarDecs:
'--------------------------------------------------------------------------------------------
'   Check variable declarations at module level outside of any procedures that
'   use the private, public, or static keywords.  Dim decs were considered in first section.
'--------------------------------------------------------------------------------------------
    'test line for keywords
    bSub = sLine Like "* Sub *"
    bFunc = sLine Like "* Function *"
    bPrivate = sLine Like "Private *"
    bPublic = sLine Like "Public *"
    bStatic = sLine Like "Static *"
    If bPrivate Or bPublic Or bStatic Then bPrivPubStat = True
    'exclude module procs but include mod vars
    If bConst Then GoTo DefaultTransfer
    If bPrivPubStat And Not bSub And Not bFunc Then
        'remove variable args brackets altogether
        sLine = RemoveVarArgs(sLine)
        'first split
        vF = Split(sLine, ",")
        For Each Elem In vF
            Elem = Trim(CStr(Elem))
            If Elem <> "" Then
                vS = Split(Elem, " ")
                'any of private, public, or withEvents could preceed var name
                For n = LBound(vS) To UBound(vS)
                    If vS(n) <> "Private" And vS(n) <> "Public" And _
                                      vS(n) <> "WithEvents" Then
                        'redim the array
                        If bNotFirst = True Then
                            'not first data transfer
                            'so increment array before transfer
                            Upper = UBound(vT) + 1
                            ReDim Preserve vT(LBound(vT) To Upper)
                        Else
                            'is first data transfer
                            'so just use first element
                            ReDim vT(1 To 1)
                            Upper = UBound(vT)
                            bNotFirst = True
                        End If
                        vT(Upper) = vS(n)
                        Exit For
                    End If
                Next n
            End If
        Next Elem
        
        'return array and results
        If UBound(vT) >= 1 Then
            If bPrivate Then
Transfers3:     sScope = "MODPRIVATE"
            ElseIf bPublic Then
                sScope = "VARPUBLIC"
            End If
                vRet = vT
            Exit Sub
        End If
    
    Else   'not a mod private ,public, etc, so...
        GoTo DefaultTransfer
    End If

DefaultTransfer:
   'no declarations in this line
   'so hand back empty vT(0 to 0)
   sScope = ""
   vRet = vT

End Sub

Function GetProcArgs(str As String) As String
    'Extracts and returns content of FIRST set of round brackets
    'This releases the procedure arguments bundle,
    'Brackets of arguments themselves removed in RemoveVarArgs.
    
    
    Dim LeadPos As Long, LagPos As Long
    Dim LeadCount As Long, LagCount As Long, Length As Long
    Dim n As Long, sTemp1 As String, m As Long
    Length = Len(Trim(str))
    For n = 1 To Length
        If Mid(str, n, 1) = "(" Then
            LeadCount = LeadCount + 1
            LeadPos = n
            For m = LeadPos + 1 To Length
                If Mid(str, m, 1) = "(" Then
                    LeadCount = LeadCount + 1
                End If
                If Mid(str, m, 1) = ")" Then
                    LagCount = LagCount + 1
                End If
                If LeadCount = LagCount And LeadCount <> 0 Then
                    LagPos = m
                    'extract the string from between Leadcount and LagCount, without brackets
                    sTemp1 = Mid(str, LeadPos + 1, LagPos - LeadPos - 1)
                    GetProcArgs = sTemp1 'return
                    Exit Function
                End If
            Next m
        End If
    Next n
End Function

Function RemoveVarArgs(ByVal str As String) As String
    'Removes ALL round brackets and their content from str input.
    'Returns modified string in function name RemoveVarArgs.
    '============================================================
    'Notes:        REMOVES ALL ROUND BRACKETS AND THEIR CONTENTS
    'the string:   dim Arr(1 to 3, 3 to (6+3)), Var() as String
    'becomes:      dim Arr, Var as String
    '============================================================
    Dim bIsAMatch As Boolean, LeadPos As Long, LagPos As Long
    Dim LeadCount As Long, LagCount As Long, Length As Long
    Dim n As Long, sTemp1 As String, sTemp2 As String, m As Long
    
    Do
    DoEvents
    bIsAMatch = str Like "*(*)*"
    If Not bIsAMatch Then Exit Do
        Length = Len(Trim(str))
        For n = 1 To Length
            If Mid(str, n, 1) = "(" Then
                LeadCount = LeadCount + 1
                LeadPos = n
            For m = LeadPos + 1 To Length
                If Mid(str, m, 1) = "(" Then
                    LeadCount = LeadCount + 1
                End If
                If Mid(str, m, 1) = ")" Then
                    LagCount = LagCount + 1
                End If
                If LeadCount = LagCount And LeadCount <> 0 Then
                    LagPos = m
                    'remove current brackets and all between them
                    sTemp1 = Mid(str, LeadPos, LagPos - LeadPos + 1)
                    sTemp2 = Replace(str, sTemp1, "", 1)
                    str = sTemp2
                    Exit For
                End If
            Next m
            End If
        bIsAMatch = str Like "*(*)*"
        If Not bIsAMatch Then Exit For
        Next n
        LeadCount = 0
        LagCount = 0
        LeadPos = 0
        LagPos = 0
    Loop
    RemoveVarArgs = str 'return

End Function

Sub EmptyTheDecLines(vA As Variant, vR As Variant)
    'Input array in vA, returned in vR modified.
    'Overwrites row 8 line string with empty string
    'if line is marked in proj array as a declaration line,
    'but leaves other parts of that record intact.
    
    Dim c As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
    vR = vA
    
    For c = Lb2 To Ub2
        If vA(13, c) = "Declaration" Then
            vR(8, c) = ""
        End If
    Next c
    
End Sub

Function MarkProcVarUse(vA As Variant, vT As Variant, vR As Variant) As Boolean
    'Updates vDec declared variables array with use data for
    'variables declared in procedures.
    'Takes vDec in vA and returns modified with markup in vR.
    'vT is the project code lines array.
    
    Dim sD As String, sL As String, n As Long, m As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of vDec input as vA
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    ReDim vR(Lb1 To Ub1, Lb2 To Ub2)

    vR = vA
     
     'step through declared variables array names
     For n = LBound(vR, 2) To UBound(vR, 2)
        'get one declared variable at a time...
        sD = vR(1, n)
        'for its associated nominal search lines...
        For m = vR(6, n) To vR(7, n)
            'and if not a declaration line...
            If vT(8, m) <> "" And vR(5, n) = "PROCPRIVATE" Then
                'get project line to check...
                sL = vT(8, m)
                'check project line against all use patterns
                If PatternCheck(sL, sD) Then
                    'mark declared var line as used
                    vR(8, n) = "Used"
                    Exit For
                Else
                End If
            End If
        Next m
     Next n
  
End Function

Function MarkModVarUse(vA As Variant, vT As Variant, vR As Variant) As Boolean
    'Updates vDec declared variables array with use data
    'for variables declared at module-private level.
    'Takes vDec in vA and returns modified with markup in vR.
    'vT is the project code lines array.
    
    Dim sA1 As String, sA2 As String, sL As String, q As Long
    Dim sD As String, n As Long, m As Long, vRet As Variant
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of vDec input as vA
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    ReDim vR(Lb1 To Ub1, Lb2 To Ub2)

    vR = vA
     
     'CHECK MODPRIVATE ALIAS NAMES IN WHOLE MODULES
     'without any line restriction
     'no harm in doing all modprivate this way first
     'step through declared variables array
     For n = Lb2 To Ub2
        'If item is modprivate...
        If vR(5, n) = "MODPRIVATE" Then
            'get both alias names for one variable...
            sA1 = vR(3, n) & "." & vR(1, n) 'mod.var
            sA2 = vR(2, n) & "." & vR(3, n) & "." & vR(1, n) 'proj.mod.var
            'for whole module line set...
            For m = vR(11, n) To vR(12, n)
                'get proj line
                sL = vT(8, m)
                'check line against vR use patterns...
                If PatternCheck(sL, sA1) Then
                    'mark declared vRriable as used
                    vR(8, n) = "Used"
                    Exit For
                End If
                If PatternCheck(sL, sA2) Then
                    'mark declared vRriable as used
                    vR(8, n) = "Used"
                    Exit For
                End If
            Next m
        Else
        'action for not modprivate
        End If
     Next n
        
     'then...
     'CHECK MODPRIVATE SHORT NAMES AGAINST WHOLE MODULES
     'excluding proc lines using vars with same names
     'step through declared variables array
     For n = Lb2 To Ub2
        'if not already found to be used in above section...
        If vR(5, n) = "MODPRIVATE" And vR(8, n) <> "Used" Then
            'get its usual short form var name
            sD = vR(1, n)
            'get a modified search range to exclude proc same-names
            NewRange vR, n, CLng(vR(6, n)), CLng(vR(7, n)), vRet
            'search for pattern match in restricted range
            For q = LBound(vRet) To UBound(vRet)
                'if not a declaration line, and n is modprivate, and a permitted search line
                If vT(8, q) <> "" And vR(5, n) = "MODPRIVATE" And vRet(q) = "" Then
                    'search in project array with line q
                    sL = vT(8, q)
                    If PatternCheck(sL, sD) Then
                        vR(8, n) = "Used"
                        Exit For
                    End If
                End If
            Next q
        End If
     Next n
     
End Function

Function MarkPubVarUse(vA As Variant, vT As Variant, vR As Variant) As Boolean
    'Updates vDec declared variables array with use data
    'for variables declared as public in module heads.
    'Takes vDec in vA and returns modified with markup in vR.
    'vT is the project code lines array.
    
    Dim sA1 As String, sA2 As String, sL As String, q As Long
    Dim sD As String, n As Long, m As Long, vRet As Variant
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of vDec input as vA
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    ReDim vR(Lb1 To Ub1, Lb2 To Ub2)

    vR = vA
     
GeneralChecks:
     
     'CHECK VARPUBLIC ALIAS NAMES IN WHOLE PROJECT
     'DO THIS IN EVERY CASE
     'without any line restrictions
     'do this for all varpublic items first
     
     'step through declared variables array
     For n = Lb2 To Ub2
        'If item is varpublic...
        If vR(5, n) = "VARPUBLIC" And vR(8, n) <> "Used" Then
            'get both alias names for one variable...
            sA1 = vR(3, n) & "." & vR(1, n) 'mod.vRr
            sA2 = vR(2, n) & "." & vR(3, n) & "." & vR(1, n) 'proj.mod.vRr
            'for whole project line set...
            For m = LBound(vT, 2) To UBound(vT, 2)
                'get proj line
                sL = vT(8, m)
                'check line against vR use patterns...
                If PatternCheck(sL, sA1) Then
                    'mark declared vRriable as used
                    vR(8, n) = "Used"
                    Exit For
                End If
                If PatternCheck(sL, sA2) Then
                    'mark declared vRriable as used
                    vR(8, n) = "Used"
                    Exit For
                End If
            Next m
        End If
     Next n
     
     'then...
     'CHECK VARPUBLIC SHORT NAME USE DEPENDING ON ANY NAME DUPLICATION
     'step through declared variables array
     For n = Lb2 To Ub2
        'if not already found to be used in above section...
        If vR(5, n) = "VARPUBLIC" And vR(8, n) <> "Used" Then
            'get its usual var name
            sD = vR(1, n)
            ' Ambiguous returns true if other pub vars use same name
            If Ambiguous(vR, n) Then
Ambiguous:     'CHECK VARPUBLIC SHORT NAME USE IN MODULES ONLY -similars already checked fully
               'get a modified search range to exclude proc same-names
                NewRange vR, n, CLng(vR(11, n)), CLng(vR(12, n)), vRet
                'run through newly permitted module search lines
                For q = LBound(vRet) To UBound(vRet)
                    'if not a declaration line, and n is modprivate, and a permitted search line
                    If vT(8, q) <> "" And vR(5, n) = "VARPUBLIC" And vRet(q) = "" Then
                        'search in project array with line q
                        sL = vT(8, q)
                        If PatternCheck(sL, sD) Then
                            vR(8, n) = "Used"
                            Exit For
                        End If
                    End If
                Next q
            Else
Unambiguous:    'resolve use when there is no ambiguous variable duplication anywhere
                'CHECK VARPUBLIC SHORT NAME USE IN WHOLE PROJECT
                'get a modified search range to exclude proc and module same-names
                NewPubRange vR, n, LBound(vT, 2), UBound(vT, 2), vRet
                'run through newly permitted project search lines
                For q = LBound(vRet) To UBound(vRet)
                    'if not a declaration line, and n is varpublic, and a permitted search line
                    If vT(8, q) <> "" And vR(5, n) = "VARPUBLIC" And vRet(q) = "" Then
                            'search in project array with line q
                            sL = vT(8, q)
                            If PatternCheck(sL, sD) Then
                                vR(8, n) = "Used"
                            Else
                            End If
                    End If
                Next q
            End If
        End If
     Next n
     
End Function

Function Ambiguous(vA As Variant, n As Long) As Boolean
    'Returns function name as true if the public variable
    'in line number n of vDec has duplicated use of its
    'name elsewhere in vDec declared variables listing,
    'by another public variable, else it is false.
    'Public variables CAN exist with same names.
    
    Dim m As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long

    'get bounds of vDec input as vA
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)

    'step through vDec as vA checking item n against all others
    For m = Lb2 To Ub2
        'if rows different,names same,projects same,and both varpublic...
        If m <> n And vA(1, n) = vA(1, m) And vA(2, n) = vA(2, m) And _
                vA(5, n) = "VARPUBLIC" And vA(5, m) = "VARPUBLIC" Then
           'there is duplication for public variable name in row n
           Ambiguous = True
           Exit Function
        End If
    Next m

End Function

Function NewPubRange(vA As Variant, n As Long, nS As Long, nE As Long, vR As Variant) As Boolean
    'Input is vDec array in vA. Returns vR array with search restriction markings.
    'Used for public variable use search in MarkPubVarUsewhen there is no ambiguous naming at all.
    'The nominal search range is input as nS and nE,and this line range will be marked to search or not.
    'Input n is vDec line number for the public variable name that needs a search data range returned.
    'vR array elements are marked "X" to avoid that line and "" to search it in the project array.
         
    Dim nSS As Long, nSE As Long
    Dim strD As String, m As Long, p As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of vDec input as vA
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)

    'set size of return array equal to number of nominal search lines
    'that is for this proc the entire project range
    ReDim vR(nS To nE)
        
    'get usual var name
    strD = vA(1, n)
    
    'search for variable name in declared variables array
    For m = Lb2 To Ub2
        'if not same rows, and var name same, and project same, and was used...
        'then its proc or module search lines all need excluded from project search
        If n <> m And strD = vA(1, m) And vA(2, n) = vA(2, m) And vA(8, m) = "Used" Then
            'get item's range to exclude
            nSS = vA(6, m) 'start nominal range for samename item
            nSE = vA(7, m) 'end nominal range for samename item
            'mark vR with exclusion marks
            For p = nSS To nSE
                vR(p) = "X" 'exclude this line
            Next p
        End If
    Next m

    NewPubRange = True

End Function

Function NewRange(vA As Variant, n As Long, nS As Long, nE As Long, vR As Variant) As Boolean
    'Used for both public and module variable name search. For short form of name.
    'Makes an array that is used to restrict the used-var search range.
    'nS and nE are start and end nominal search line numbers.
    'Input is vDec in vA, n is vDec line number for variable under test, vR is return array.
    'returns array vR marked "X" for exclusion of search where a procedure has a
    'same-name variable to that of line n in vDec.   Restricts the nominal search range.
         
    Dim nSS As Long, nSE As Long
    Dim strD As String, m As Long, p As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of vDec input as vA
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)

    'set size of return array equal to number of nominal search lines
    ReDim vR(nS To nE)
        
    'get usual var name
    strD = vA(1, n)
    
    'search for variable name in declared variables array
    For m = Lb2 To Ub2
        'if not same rows, and var name same, and project same, and module same, and has a procedure name,
        'and was used...then its proc search lines all need excluded from module search
        If n <> m And strD = vA(1, m) And vA(2, n) = vA(2, m) And vA(3, n) = vA(3, m) And _
                 vA(4, m) <> "" And vA(8, m) = "Used" Then 'in a proc
            'get item's range to exclude
            nSS = vA(6, m) 'start nominal range for samename item
            nSE = vA(7, m) 'end nominal range samename item
            'mark vR with exclusion marks
            For p = nSS To nSE
                vR(p) = "X" 'exclude this line
            Next p
        End If
    Next m

    NewRange = True

End Function

Function StartOfRng(vA As Variant, sScp As String, n As Long) As Long
    'Returns line number in function name that starts nominal search range.
    'Information already on the project array.
    
    
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
    
    'get bounds of project array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)

    'get ranges using new line numbers in row 6
    
        Select Case sScp
           Case "PROCPRIVATE"
               StartOfRng = vA(11, n)
           Case "MODPRIVATE"
               StartOfRng = vA(9, n)
           Case "VARPUBLIC"
               StartOfRng = LBound(vA, 2)
           Case "DECLARED"
               'StartOfRng = vA(9, n)
           Case Else
               MsgBox "Dec var scope not found"
        End Select
    
End Function

Function EndOfRng(vA As Variant, sScp As String, n As Long) As Long
    'Returns line number in function name for end of used search
    'Information already on the project array
    
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
        
    'get bounds of project array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)

    'get ranges using new line numbers in row 6
    
        Select Case sScp
           Case "PROCPRIVATE"
               EndOfRng = vA(12, n)
           Case "MODPRIVATE"
               EndOfRng = vA(10, n)
           Case "VARPUBLIC"
               EndOfRng = UBound(vA, 2)
           Case "DECLARED"
               'EndOfRng = vA(10, n)
           Case Else
               MsgBox "Dec var scope not found"
        End Select

End Function

Sub PrintArrayToSheet(vA As Variant, sSht As String)
    'Used at various points in project to display test info
    'Writes input array vA to sSht with top left at cells(1,1)
    'Sheet writing assumes lower bound of array is 1
    'Makes use of Transpose2DArr()
    
    Dim sht As Worksheet, r As Long, c As Long
    Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long, vRet As Variant
    
    Transpose2DArr vA, vRet
    'get bounds of project array
    
    Lb1 = LBound(vRet, 1): Ub1 = UBound(vRet, 1)
    Lb2 = LBound(vRet, 2): Ub2 = UBound(vRet, 2)
    
    If Lb1 <> 0 And Lb2 <> 0 And Ub1 <> 0 And Ub2 <> 0 Then
        Set sht = ThisWorkbook.Worksheets(sSht)
        sht.Activate
        For r = Lb1 To Ub1
            For c = Lb2 To Ub2
                sht.Cells(r, c) = vRet(r, c)
            Next c
        Next r
        sht.Cells(1, 1).Select
    Else
        'MsgBox "No redundant variables found."
    End If

End Sub

Function Transpose2DArr(ByRef vA As Variant, Optional ByRef vR As Variant) As Boolean
    ' Used in both user form and sheet output displays.
    ' Transposes a 2D array of numbers or strings.
    ' Returns the transposed vA array as vR with vA intact.
        
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim r As Long, c As Long

    'find bounds of vA data input array
    loR = LBound(vA, 1): hiR = UBound(vA, 1)
    loC = LBound(vA, 2): hiC = UBound(vA, 2)

    'set vR dimensions transposed
    'If Not IsMissing(vR) Then
    If IsArray(vR) Then Erase vR
    ReDim vR(loC To hiC, loR To hiR)
    'End If

    'transfer data
    For r = loR To hiR
        For c = loC To hiC
            'transpose vA into vR
            vR(c, r) = vA(r, c)
        Next c
    Next r

Transfers:

    'return success for function
    Transpose2DArr = True

End Function

Sub StrToNextRow(sIn As String, sSht As String, Optional nCol As Long = 1)
    'Writes to next free row of nCol.
    'Optional parameter nCol defaults to unity.
    'sIn: String input to display, sSht: Worksheet string name to write to.
        
    Dim sht As Worksheet, nRow As Long
    
    Set sht = ThisWorkbook.Worksheets(sSht)
    sht.Activate
    nRow = Cells(Rows.Count, nCol).End(xlUp).Row + 1
    sht.Cells(nRow, nCol).Activate
    ActiveCell.Value = sIn

End Sub

Function PatternCheck(sLine As String, sDec As String) As Boolean
    'Used to determine whether or not a declared variable is used.
    'Returns PatternCheck as true if sDec was used
    'in sLine, else false. sDec is the declared variable
    'and sLine is the previously modified code line.   Modifications
    'removed quotes and comments that can cause error.
    'Checks against a set of common use patterns.
    
    'Dim sLine As String, sDec As String
    Dim bIsAMatch As Boolean, n As Long
    Dim Lb2 As Long, Ub2 As Long
    
    For n = Lb2 To Ub2
        'if parameter found in format of pattern returns true - else false
        
        'IN ORDER OF FREQUENCY OF USE;
        'PATTERNS FOR FINDING WHETHER OR NOT A VARIABLE IS USED IN A LINE STRING
                
        'A = Var + 1   or   A = b + Var + c
        bIsAMatch = sLine Like "* " & sDec & " *"   'spaced both sides
        If bIsAMatch Then Exit For
                    
        'Var = 1
        bIsAMatch = sLine Like sDec & " *"          'lead nothing and lag space
        If bIsAMatch Then Exit For
        
        'B = Var
        bIsAMatch = sLine Like "* " & sDec          'lead space and lag nothing
        If bIsAMatch Then Exit For
        
        'Sub Name(Var, etc)
        bIsAMatch = sLine Like "*(" & sDec & ",*"   'lead opening bracket and lag comma
        If bIsAMatch Then Exit For
        
        'B = C(n + Var)
        bIsAMatch = sLine Like "* " & sDec & ")*"   'lead space and lag close bracket
        If bIsAMatch Then Exit For
        
        'B = "t" & Var.Name
        bIsAMatch = sLine Like "* " & sDec & ".*"   'lead space and lag dot
        If bIsAMatch Then Exit For
        
        'B = C(Var + n)
        bIsAMatch = sLine Like "*(" & sDec & " *"   'lead open bracket and lag space
        If bIsAMatch Then Exit For
        
        'B = (Var)
        bIsAMatch = sLine Like "*(" & sDec & ")*"   'lead open bracket and lag close bracket
        If bIsAMatch Then Exit For
        
        'Var.Value = 5
        bIsAMatch = sLine Like sDec & ".*"          'lead nothing and lag dot
        If bIsAMatch Then Exit For
        
        'A = Var(a, b)
        'Redim Var(1 to 6, 3 to 8)  'ie: redim is commonly treated as use, but never as declaration.
        bIsAMatch = sLine Like "* " & sDec & "(*"   'lead space and lag open bracket
        If bIsAMatch Then Exit For
                    
        'Var(a) = 1
        bIsAMatch = sLine Like sDec & "(*"          'lead nothing and lag open bracket
        If bIsAMatch Then Exit For
        
        'B = (Var.Name)
        bIsAMatch = sLine Like "*(" & sDec & ".*"   'lead opening bracket and lag dot
        If bIsAMatch Then Exit For
        
        'SubName Var, etc
        bIsAMatch = sLine Like "* " & sDec & ",*"   'lead space and lag comma
        If bIsAMatch Then Exit For
        
        'B = (Var(a) - c)
        bIsAMatch = sLine Like "*(" & sDec & "(*"   'with lead open bracket and lag open bracket
        If bIsAMatch Then Exit For
        
        'Test Var:=Name
        bIsAMatch = sLine Like "* " & sDec & ":*"   'lead space and lag colon
        If bIsAMatch Then Exit For
                    
        'Test(A:=1, B:=2)
        bIsAMatch = sLine Like "*(" & sDec & ":*"   'lead opening bracket and lag colon
        If bIsAMatch Then Exit For
        
        'SomeSub str:=Var
        bIsAMatch = sLine Like "*:=" & sDec         'lead colon equals and lag nothing
        If bIsAMatch Then Exit For
        
        'test arg1:=b, arg2:=A + 1
        bIsAMatch = sLine Like "*:=" & sDec & " *"  'lead colon equals and lag space
        If bIsAMatch Then Exit For
        
        'test arg1:=b, arg2:=A(1) + 1
        bIsAMatch = sLine Like "*:=" & sDec & "(*"  'lead colon equals and lag opening bracket
        If bIsAMatch Then Exit For
        
        'SomeSub (str:=Var)
        bIsAMatch = sLine Like "*:=" & sDec & ")*"  'lead colon equals and lag closing bracket
        If bIsAMatch Then Exit For
        
        'SomeSub str:=Var, etc
        bIsAMatch = sLine Like "*:=" & sDec & ",*"  'lead colon equals and lag comma
        If bIsAMatch Then Exit For
        
        'SomeSub str:=Var.Value etc
        bIsAMatch = sLine Like "*:=" & sDec & ".*"  'lead colon equals and lag dot
        If bIsAMatch Then Exit For
                    
        'SomeModule.Var.Font.Size = 10
'        bIsAMatch = sLine Like "*." & sDec & ".*"   'lead dot and lag dot
'        If bIsAMatch Then Exit For
        
        'SomeModule.Var(2) = 5
'        bIsAMatch = sLine Like "*." & sDec & "(*"   'lead dot and lag opening bracket
'        If bIsAMatch Then Exit For
        
        'SomeModule.Var = 3
'        bIsAMatch = sLine Like "*." & sDec & " *"   'lead dot and lag space
'        If bIsAMatch Then Exit For
       
    Next n
    
    If bIsAMatch Then
        PatternCheck = True
        'MsgBox "Match found"
        Exit Function
    Else
        'MsgBox "No match found"
        'Exit Function
    End If

End Function

Sub AutoLayout(vA As Variant, Optional bTranspose As Boolean = False)
    ' Takes array vA of say, 4 columns of data and
    ' displays on textbox in tabular layout.
    ' Needs a userform called ViewVars and a textbox
    ' called Textbox1.  Code will adjust layout.
    ' Transpose2DArr used only to return data to (r, c) format.
    
    Dim vB As Variant, vL As Variant, vR As Variant
    Dim r As Long, c As Long, m As Long, sS As String
    Dim nNumPadSp As Long, TxtLab As Control, MaxFormWidth As Long
    Dim sAccum As String, sRowAccum As String, bBold As Boolean
    Dim nLineLen As Long, BoxFontSize As Long, BoxFontName As String
    Dim sLabAccum As String, nLabPadSp As Long, oUserForm As Object
    Dim Backshade As Long, BoxShade As Long, BoxTextShade As Long
    Dim ButtonShade As Long, ButtonTextShade As Long
    Dim Lb1 As Long, Ub1 As Long, Lb2 As Long, Ub2 As Long
    Dim TextLength As Long, bItalic As Boolean
    
    ' decide to transpose input or not
    If bTranspose = True Then
        Transpose2DArr vA, vR
        vA = vR
    End If
        
    ' get bounds of display array
    Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
    Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
    
    ReDim vL(Lb2 To Ub2) ' make labels array
    ReDim vB(Lb2 To Ub2) ' dimension column width array
    
    '--------------------------------------------------------------
    '                   SET USER OPTIONS HERE
    '--------------------------------------------------------------
    ' set the name of the userform made at design time
    Set oUserForm = ViewVars
    
    ' set limit for form width warning
    MaxFormWidth = 800
    
    ' make column labels for userform - set empty if not needed
    vL = Array("Variable", "Procedure", "Module", "Project")
    
    ' colors
    Backshade = RGB(31, 35, 44)          'almost black -   used
    ButtonShade = RGB(0, 128, 128)       'blue-green - not used
    BoxShade = RGB(0, 100, 0)            'middle green -   used
    ButtonTextShade = RGB(230, 230, 230) 'near white - not used
    BoxTextShade = RGB(255, 255, 255)    'white -          used
    ' Font details are to be found below
    '--------------------------------------------------------------
    
    ' find maximum width of array columns
    ' taking account of label length also
    For c = Lb2 To Ub2
        m = Len(vL(c)) 'label
        For r = Lb1 To Ub1
            sS = vA(r, c) 'value
            If Len(sS) >= m Then
                m = Len(sS)
            End If
        Next r
        'exits with col max array
        vB(c) = m
        m = 0
    Next c
   
   ' For testing only
   ' shows max value of each column
'   For c = LB2 To UB2
'       MsgBox vB(c)
'   Next c
    
    For r = Lb1 To Ub1
        For c = Lb2 To Ub2
            If c >= Lb2 And c < Ub2 Then
                ' get padding for current element
                nNumPadSp = vB(c) + 2 - Len(vA(r, c))
            Else
                ' get padding for last element
                nNumPadSp = vB(c) - Len(vA(r, c))
            End If
                ' accumulate line with element padding
            sAccum = sAccum & vA(r, c) & Space(nNumPadSp)
                ' get typical line length
            If r = Lb1 Then
                sRowAccum = sRowAccum & vA(Lb1, c) & Space(nNumPadSp)
                nLineLen = Len(sRowAccum)
            End If
        Next c
                ' accumulate line strings
                sAccum = sAccum & vbNewLine
    Next r

    ' accumulate label string
    For c = Lb2 To Ub2
        If c >= Lb2 And c < Ub2 Then
            ' get padding for current label
            nLabPadSp = vB(c) + 2 - Len(vL(c))
        Else
            ' get padding for last element
            nLabPadSp = vB(c) - Len(vL(c))
        End If
        ' accumulate the label line
        sLabAccum = sLabAccum & vL(c) & Space(nLabPadSp)
    Next c
        
    ' load user form
    Load oUserForm
    
    '================================================================
    '       SET FONT DETAILS HERE. THESE AFFECT ALL AUTOSIZING.
    '================================================================
    BoxFontSize = 12         'say between 6 to 20 points
    bBold = True             'True for bold, False for regular
    bItalic = False          'True for italics, False for regular
    BoxFontName = "Courier"  'or other monospaced fonts eg; Consolas
    '================================================================
      
    ' make the labels textbox
    Set TxtLab = oUserForm.Controls.Add("Forms.TextBox.1", "TxtLab")
    
    ' format the labels textbox
    With TxtLab
        .WordWrap = False
        .AutoSize = True 'extends to fit text
        .Value = ""
        .font.Name = BoxFontName
        .font.SIZE = BoxFontSize
        .font.Bold = bBold
        .font.Italic = bItalic
        .ForeColor = BoxTextShade
        .Height = 20
        .Left = 20
        .Top = 15
        .Width = 0
        .BackStyle = 0
        .BorderStyle = 0
        .SpecialEffect = 0
    End With
    
    'apply string to test label to get length
    TxtLab.Value = sLabAccum & Space(4)
    TextLength = TxtLab.Width
    'MsgBox TextLength
    
    'format userform
    With oUserForm
        .BackColor = Backshade
        .Width = TextLength + 40
        .Height = 340
        .Caption = "Redundant variables list..."
    End With
      
    ' check user form is within max width
    If oUserForm.Width > MaxFormWidth Then
        MsgBox "Form width is excessive"
        Unload oUserForm
        Exit Sub
    End If
    
    'format the data textbox
    With oUserForm.TextBox1
        .ScrollBars = 3
        .WordWrap = True
        .MultiLine = True
        .EnterFieldBehavior = 1
        .BackColor = BoxShade
        .font.Name = BoxFontName
        .font.SIZE = BoxFontSize
        .font.Bold = bBold
        .font.Italic = bItalic
        .ForeColor = BoxTextShade
        .Height = 250
        .Left = 20
        .Top = 40
        .Width = TextLength
        .Value = sAccum
    End With
    
    'show the user form
    oUserForm.Show

End Sub


Array Data To Immediate Window

Summary[edit | edit source]

This VBA code module allows the listing of arrays in the immediate window. So that the user can see examples of its use, it makes use of various procedures that fill the array for demonstration and testing. The VBA code runs in MS Excel but is easily adapted for any of the MS Office products that run VBA. Clearly, mixed data varies in length and in its number of decimal points. This module displays the array neatly taking account of the variations that might otherwise disrupt the layout. It can decimal point align the data or not, according to internal options.

Code Notes[edit | edit source]

  • DispArrInImmWindow() is the main procedure. It formats and prints data found on the two dimensional input array. It prints on the VBA Editor's Immediate Window. Options include the printing of data as found or making use of decimal rounding and alignment. The entire output print is also available as a string for external use. The process depends on monospaced fonts being set for any display, including the VBA editor.
  • RndAlphaToArr(), RndNumericToArr(), and RndMixedDataToArr() load an array with random data. The data is random in the content and length of elements, but in addition, numerics have random integer and decimal parts. Each allows adjustment of options internally to accommodate personal preferences.
  • TabularAlignTxtOrNum() is not used in this demonstration. It is included for those who prefer to format each individual column of an array during the loading process. Its input variant takes a single string or number and returns the formatted result in a user-set fixed field width. The number of decimal places of rounding can be set. Note that when all data in a column of a numeric array is loaded with the same parameters, the result is always decimal point alignment.
  • WriteToFile() is a monospaced font, text file-making procedure. If the file name does not exist, it will be made and saved automatically. Each save of text will completely replace any previously added. It is added here in case a user needs to save an output greater than that possible for the Immediate Window. The Immediate Window is limited to about two hundred lines of code, so large arrays should make use of the main procedure's sOut string. Again, wherever outputs from the main procedure are used, monospaced fonts are assumed.
  • Note that the user might add a procedure to export large values of sOut, the formatted string, to the clipboard. Procedures exist elsewhere in this series that will accomplish this.

The VBA Module[edit | edit source]

Copy the entire code module into a standard VBA module, save the file as type .xlsm and run the top procedure. Be sure to set monospaced fonts for the VBA editor or the object will have been defeated.

Updates[edit | edit source]

  • 26 Nov 2019: Adjusted DispArrInImmWindow() code to better estimate maximum column width, taking account of imposed decimal places.
Option Explicit

Private Sub testDispArrInImmWindow()
    'Run this to display a selection of data arrays
    'in the immediate window. Auto formatting
    'includes rounding and decimal point alignment.
    'Alternative is to print data untouched.
    'SET IMMEDIATE WINDOW FONT TO MONOSPACED
    'Eg: Consolas or Courier.
    
    Dim vArr As Variant, vArr2 As Variant, sOutput As String
     
    'clear the immediate window
    ClearImmWindow
    
    'UNFORMATTED random length alpha strings
    RndAlphaToArr vArr, 5, 6        'length setting made in proc
    vArr2 = vArr
    Debug.Print "UNFORMATTED"
    DispArrInImmWindow vArr, False, 2
    'FORMATTED random length alpha strings
    Debug.Print "FORMATTED"
    DispArrInImmWindow vArr2, True, 2
    
    
    'UNFORMATTED random length numbers and decimals
    RndNumericToArr vArr, 5, 6      'various settings made in proc
    vArr2 = vArr
    Debug.Print "UNFORMATTED"
    DispArrInImmWindow vArr, False, 2
    'FORMATTED random length numbers and decimals
    Debug.Print "FORMATTED"
    DispArrInImmWindow vArr2, True, 2
    
        
    'UNFORMATTED random alpha and number alternating columns
    RndMixedDataToArr vArr, 5, 6    'various settings made in proc
    vArr2 = vArr
    Debug.Print "UNFORMATTED"
    DispArrInImmWindow vArr, False, 2
    'FORMATTED random alpha and number alternating columns
    Debug.Print "FORMATTED"
    DispArrInImmWindow vArr2, True, 2, sOutput
    
    'output whole string version to a log file
    'WriteToFile sOutput, ThisWorkbook.Path & "\MyLongArray.txt"

End Sub

Private Sub ClearImmWindow()
    
    'NOTES
    'Clears VBA immediate window down to the insertion point,
    'but not beyond. Not a problem as long as cursor is
    'at end of text, but otherwise not.
    'Clear manually before any neat work.
    'Manual clear method: Ctrl-G then Ctrl-A then Delete.
    
    'Max display in immediate window is 199 lines,
    'then top lines are lost as new ones added at bottom.
    'No reliable code method exists.
    
    Debug.Print String(200, vbCrLf)
    
End Sub

Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
                                  Optional ByVal nNumDecs As Integer = 2, _
                                     Optional sOut As String)

    '--------------------------------------------------------------------------
    'vA :               Input 2D array for display in the immediate window.
    'sOut:              Alternative formatted output string.
    'bFormatAlignData : True: applies decimal rounding and decimal alignment,
    '                   False: data untouched with only basic column spacing.
    'nNumDecs:          Sets the rounding up and down of decimal places.
    '                   Integers do not have zeros added at any time.
    'Clear the immediate window before each run for best results.
    'The immediate window at best lists 199 lines before overwrite, so
    'consider using sOut for large arrays.  'ie; use it in a text file
    'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
    'so set the font VBA editor or any textbox to Courier or Consolas.
    'To set different formats for EVERY column of an array it is best to add
    'the formats at loading time with the procedure TabularAlignTxtOrNumber().
    '--------------------------------------------------------------------------
    
    'messy when integers are set in array and decimals is set say to 3.
    'maybe the measurement of max element width should include a measure
    ' for any dot or extra imposed decimal places as well
    'different for integers and for existing decimals
        
    Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
    Dim sPadding As String, sDecFormat As String, sR As String, sE As String
    Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
    Dim nMaxFieldWidth As Integer, bSkip As Boolean
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    'get bounds of input array
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
    
    ReDim vD(LB1 To UB1, LB2 To UB2) 'display
    ReDim vC(LB2 To UB2)             'column max
    
    '--------------------------------------
    'set distance between fixed width
    'fields in the output display
    nInterFieldSpace = 3
    'not now used
    nMaxFieldWidth = 14
    '--------------------------------------
    
    If nNumDecs < 0 Then
        MsgBox "nNumDecs parameter must not be negative - closing"
        Exit Sub
    End If
        
    'find widest element in each column
    'and adjust it for any imposed decimal places
    For c = LB2 To UB2
        n = 0: m = 0
        For r = LB1 To UB1
            'get element length
            If IsNumeric(vA(r, c)) Then
                If Int(vA(r, c)) = vA(r, c) Then 'is integer
                    n = Len(vA(r, c)) + 1 + nNumDecs
                Else 'is not integer
                    If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
                        n = Len(vA(r, c))
                    Else  'add the difference in length as result of imposed decimal places
                        n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
                    End If
                End If
            Else
                n = Len(vA(r, c))
            End If
            
            If n > m Then m = n 'update if longer
        Next r
        'store the maximum length
        'of data in each column
        vC(c) = m
    Next c
        
    For c = LB2 To UB2
        For r = LB1 To UB1
            sE = Trim(vA(r, c))

            If bFormatAlignData = False Then
                sDecFormat = sE
                nP = InStr(sE, ".")
                bSkip = True
            End If

            'make a basic format
            If bSkip = False Then
                nP = InStr(sE, ".")
                'numeric with a decimal point
                If IsNumeric(sE) = True And nP > 0 Then
                    sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
                'integer
                ElseIf IsNumeric(sE) = True And nP <= 0 Then
                    sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
                'alpha
                ElseIf IsNumeric(sE) = False Then
                    sDecFormat = sE
                End If
            End If
  
            'adjust field width to widest in column
            bSkip = False
            sPadding = Space$(vC(c))
            'numeric with a decimal point
            If IsNumeric(sE) = True And nP > 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'integer
            ElseIf IsNumeric(sE) = True And nP <= 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'alpha
            ElseIf IsNumeric(sE) = False Then
                vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
            End If
        Next r
    Next c
        
    'output
    sOut = ""
    For r = LB1 To UB1
        For c = LB2 To UB2
            sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
        Next c
        Debug.Print sR             'print one row in imm window
        sOut = sOut & sR & vbCrLf  'accum one row in output string
        sR = ""
    Next r
    sOut = sOut & vbCrLf
    Debug.Print vbCrLf

End Sub

Private Sub RndAlphaToArr(vIn As Variant, nRows As Integer, nCols As Integer)
    'loads a 2D array in place with random string lengths
            
    Dim sT As String, sAccum As String, nMinLenStr As Integer
    Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
    Dim nAsc As Integer, r As Long, c As Long
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
        
    '--------------------------------------------------
    'set minimum and maximum strings lengths here
    nMinLenStr = 2   'the minimum random text length
    nMaxLenStr = 8  'the maximum random text length
    '--------------------------------------------------
    
    Randomize
    For r = LB1 To UB1
        For c = LB2 To UB2
            nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
            
            'make one random length string
            For n = 1 To nLenWord
                nAsc = Int((90 - 65 + 1) * Rnd + 65)
                sT = Chr$(nAsc)
                sAccum = sAccum & sT
            Next n
            
            'store string
            vIn(r, c) = sAccum
            sAccum = "": sT = ""
        Next c
    Next r

End Sub

Private Sub RndNumericToArr(vIn As Variant, nRows As Integer, nCols As Integer)
    'loads a 2D array in place with random number lengths
    
    Dim sT1 As String, sT2 As String, nMinLenDec As Integer, sSign As String
    Dim sAccum1 As String, sAccum2 As String, nMaxLenDec As Integer
    Dim nLenInt As Integer, nLenDecs As Integer, nMinLenInt As Integer
    Dim n As Long, r As Long, c As Long, nAsc As Integer, nMaxLenInt As Integer
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
      
    '--------------------------------------------------
    'set user minimum and maximum settings here
    nMinLenDec = 0   'the minumum decimal part length
    nMaxLenDec = 4   'the maximum decimal part length
    nMinLenInt = 1   'the minimum integer part length
    nMaxLenInt = 4   'the maximum integer part length
    '--------------------------------------------------
    
    Randomize
    For r = LB1 To UB1
        For c = LB2 To UB2
            nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
            nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
            'make one random length integer string
            For n = 1 To nLenInt
                    If nLenInt = 1 Then                      'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    ElseIf nLenInt <> 1 And n = 1 Then       'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    Else
                        nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
                    End If
                    
                    sT1 = Chr$(nAsc)
                    sAccum1 = sAccum1 & sT1
                Next n
            'make one random length decimal part
            For n = 0 To nLenDecs
                nAsc = Int((57 - 48 + 1) * Rnd + 48)
                sT2 = Chr$(nAsc)
                sAccum2 = sAccum2 & sT2
            Next n
            'decide whether or not a negative number
            nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
            If nAsc = 5 Then sSign = "-" Else sSign = ""
            
            'store string
            If nLenDecs <> 0 Then
                vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
            Else
                vIn(r, c) = CSng(sSign & sAccum1)
            End If
                    
            sT1 = "": sT2 = ""
            sAccum1 = "": sAccum2 = ""
            'MsgBox vIn(r, c)
        Next c
    Next r
End Sub

Private Sub RndMixedDataToArr(vIn As Variant, nRows As Integer, nCols As Integer)
    'loads a 2D array in place with random string lengths
    
    Dim sAccum As String, nMinLenStr As Integer, sSign As String
    Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
    Dim nAsc As Integer, r As Long, c As Long, nMaxLenDec As Integer
    Dim sT As String, sT1 As String, sT2 As String, nMinLenDec As Integer
    Dim sAccum1 As String, sAccum2 As String, nMinLenInt As Integer
    Dim nLenInt As Integer, nLenDecs As Integer, nMaxLenInt As Integer
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
        
    '--------------------------------------------------
    'set user minimum and maximum settings here
    nMinLenStr = 3   'the minimum random text length
    nMaxLenStr = 8   'the maximum random text length
    nMinLenDec = 0   'the minumum decimal part length
    nMaxLenDec = 4   'the maximum decimal part length
    nMinLenInt = 1   'the minimum integer part length
    nMaxLenInt = 4   'the maximum integer part length
    '--------------------------------------------------
    
    Randomize
    For r = LB1 To UB1
        For c = LB2 To UB2
            If c Mod 2 <> 0 Then
                
                nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
                
                'make one random length string
                For n = 1 To nLenWord
                    nAsc = Int((90 - 65 + 1) * Rnd + 65)
                    sT = Chr$(nAsc)
                    sAccum = sAccum & sT
                Next n
                
                'store string
                vIn(r, c) = sAccum
                sAccum = "": sT = ""
            Else
                nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
                nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
                'make one random length integer string
                For n = 1 To nLenInt
                    If nLenInt = 1 Then                      'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    ElseIf nLenInt <> 1 And n = 1 Then       'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    Else
                        nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
                    End If
                    
                    sT1 = Chr$(nAsc)
                    sAccum1 = sAccum1 & sT1
                Next n
                'make one random length decimal part
                If nLenDecs <> 0 Then
                    For n = 1 To nLenDecs
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                        sT2 = Chr$(nAsc)
                        sAccum2 = sAccum2 & sT2
                    Next n
                Else
                        sAccum2 = ""
                End If
                'decide whether or not a negative number
                nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
                If nAsc = 5 Then sSign = "-" Else sSign = ""
                            
                'store string
                If nLenDecs <> 0 Then
                    vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
                Else
                    vIn(r, c) = CSng(sSign & sAccum1)
                End If
                        
                sT1 = "": sT2 = ""
                sAccum1 = "": sAccum2 = ""
            End If
        Next c
    Next r

End Sub

Sub testNumDecAlign()
    'produces examples in immediate window for single entries
    
    'clear the immediate window
    ClearImmWindow
    
    Debug.Print "|" & TabularAlignTxtOrNum(Cos(30), 3, 12) & "|"
    Debug.Print "|" & TabularAlignTxtOrNum("Text Heading", 3, 12) & "|"
    Debug.Print "|" & TabularAlignTxtOrNum(345.746453, 3, 12) & "|"
    Debug.Print "|" & TabularAlignTxtOrNum(56.5645, 0, 12) & "|"
    Debug.Print vbCrLf

End Sub

Private Function TabularAlignTxtOrNum(vIn As Variant, nNumDecs As Integer, _
                      nFieldWidth As Integer) As String
    'Notes:
    'Returns vIn in function name, formatted to given number of decimals,
    'and padded for display. VIn can contain an alpha string, a numeric
    'string, or a number. nNumDecs is intended number of decimals
    'in the output and nFieldWidth is its total padded width.
    'Non-numerics are left-aligned and numerics are right-aligned.
    'Decimal alignment results when say, all of an array column is
    'formatted with the same parameters.
    'ASSUMES THAT A MONOSPACED FONT WILL BE USED FOR DISPLAY
    
    Dim sPadding As String, sDecFormat As String
        
    'make a format based on whether numeric and how many decimals
    If IsNumeric(vIn) Then
        If nNumDecs > 0 Then                 'decimals
            sDecFormat = Format$(vIn, "0." & String$(nNumDecs, "0"))
        Else
            sDecFormat = Format$(vIn, "0") 'no decimals
        End If
    Else
            sDecFormat = vIn                 'non numeric
    End If
            
    'get a space string equal to max width
    sPadding = Space$(nFieldWidth)
    
    'combine and limit width
    If IsNumeric(vIn) Then
    'combine and limit width
        TabularAlignTxtOrNum = Right$(sPadding & sDecFormat, nFieldWidth)
    Else
        TabularAlignTxtOrNum = Left$(sDecFormat & sPadding, nFieldWidth)
    End If

End Function

Function WriteToFile(sIn As String, sPath As String) As Boolean
    'REPLACES all content of text file with parameter string
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim Number As Integer
    
    Number = FreeFile 'Get a file number
    
    'write string to file
    Open sPath For Output As #Number
    Print #Number, sIn
    Close #Number

    WriteToFile = True
    
End Function

See Also[edit | edit source]


Viterbi Simulator in VBA

Summary[edit | edit source]

This code is made for Excel. It simulates the behavior of a data channel's convolutional coding, though by necessity it concentrates on simple examples. Two rate 1/2 systems are provided; both with three stages, one for generator polynomial (111,110), and the other for (111,101). The code was written to improve understanding of the Wikibooks page A Basic Convolutional Coding Example, but might also be of elementary use for students without other software. The code concentrates on random errors of the type caused by Gaussian noise sources. Blank work sheets can be found in the drop-box below:

Blank Work Sheets for (7,5) and (7,6) Configurations
Viterbi Trellis Worksheet for configuration (7,6)
Viterbi Trellis Worksheet for configuration (7,5)


The Simulator[edit | edit source]

This simulator uses Closeness to calculate its metrics.

For each of the two configurations, rudimentary options have been provided. No user form has been included here, the author preferring to modify the settings directly in the top procedure's code. The branch metrics make use of CLOSENESS as opposed to HAMMING DISTANCE. A version using HAMMING DISTANCE can be found on an adjacent page.

  • User mode settings allow various combinations of inputs and errors to be applied.
  • Both coders produce two bits of output for every one bit of input. The message input (display stream m) can be specified by the user, manually or generated randomly to any given length. The decoder output message is distinguished from the original as m*.
  • The user can run one cycle or many. Long cycle averaging is often useful. A message box summarizes the BER (bit error rate) results across all cycles. The user can output the metrics and basic streams for one chosen cycle to the worksheet.
  • The coder output is modified to include errors. This simulates the effect of random noise in a transmission channel. The user can set specific errors in exact positions or apply random errors throughout to a specified bit error rate. Recall that error bit positions apply to the output of the coder and that the number of bits there will be double that of the message input.
  • The display streams are labeled. The user can display the metrics and streams for a cycle. The streams are:
    • m is the original message input to the coder.
    • c is the coded output from the coder without any errors.
    • r is the received version of the coder output with the applied errors.
    • m* is the decoder output, the recovered message.

The VBA Code[edit | edit source]

The code is provided below in one complete module. Copy the code into a standard module. Set options in the top procedure RunCoding, then run that procedure to obtain a summary of error correcting results. The process will clear Sheet1, so be sure that no other essential work is located there. As an example of setting the options, assume that the intention is to test the performance of the 7,5 configuration with both random inputs and random errors to BER 0.01. Proceed as follows:

  • Set nCodePolyGen= 75 to select the 111,101 configuration,
  • nModeNumber = 8 for random inputs with random errors,
  • nAutoCycles = 100 for the average of 100 blocks,
  • nLenAutoInput = 500 to use five hundred bits in each input block,
  • nNumCdrFlushBits = 3 to add flushing bits at end of each input block,
  • sngBER = 0.01 to apply one percent errors,
  • Other options can be ignored for this task.
  • Run the procedure RunCodingC. Output for the first cycle will be displayed on sheet one, and a summary for the changed BER across the decoder will appear on a message box when the run is complete.. Re-save the code or press the editor's reset button between runs with new parameters.

The Module[edit | edit source]

Modification 14/Aug/18; removed column numbers restriction. User responsibility now.
Code Functional 11/Aug/18.
Modification 11/Aug/18; corrected ColourTheErrors() procedure.
Modification 23/Mar/18; removed subroutine Notes as redundant.
Modification 03/Nov/17; added back path edge stream to sheet display.
Modification 01/Nov/17; corrected coding errors.
Modification 31/Oct/17; added back path coloring.

Option Explicit

Sub RunCodingC() ' FOR CLOSENESS METHODS
    ' Run this procedure with chosen in-code settings to study the cross-decoder performance.
    ' Runs a Viterbi convolutional coder-decoder simulation for two rate 1/2 algorithms.
    ' Coder 7,6: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(110), Dfree=4.
    ' Coder 7,5: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(101), Dfree=5.
    ' Decoders; Viterbi to match each coder. VBA is coded for CLOSENESS as opposed to Hamming DISTANCE.
    ' Message inputs can be specified exactly, or randomly with chosen length.
    ' Error insertion can be exact, or random to a specified BER. Various error pair options exist.
    ' User set number of cycles and output choice. Message box for an all-cycle summary.
Notes:
    ' The 7,5 coding algorithm with the higher "free distance" = 5 is better than 7,6's with FD = 4.
    ' Configuration (7,6) handles single bit errors with error free gaps of at least six bits.
    ' Configuration (7,6) handles some errored pairs in a limited way for some input conditions.
    ' Configuration (7,5) handles single bit errors with error free gaps of at least five bits.
    ' Configuration (7,5) handles errored pairs also, with error free gaps of about 12 -15 bits between such pairs.
    ' Performance Compared: Random Inputs with Random Errors: For 1Mb total input:
    ' (7,6): BER 1E-3 in, 4E-6 out: BER 1E-2 in, 6E-4 out.
    ' (7,5): BER 1E-3 in, 1E-6 out: BER 1E-2 in, 3E-5 out.
    
Assignments:
    Dim oSht As Worksheet, vArr As Variant, vEM As Variant, bLucky As Boolean, vDisp As Variant
    Dim sngBerDecIn As Single, sngBER As Single, sngBerMOut As Single, nModeNumber As Integer
    Dim LB1 As Long, UB1 As Long, x As Long, nClearErrGap As Long, nNumCdrFlushBits As Long
    Dim m As Long, nLenAutoInput As Long, nAutoCycles As Long, rd As Long, cd As Long
    Dim r As Long, nLenStream As Long, nMErr As Long, nTotMErr As Long, nTotDIErr As Long
    Dim nTotLenStream As Long, nDErr As Long, nLenIntoDec As Long, nCycleToDisplay As Long
    Dim nTotMBSent As Long, nTotEBMess As Long, nNumDEPC As Long, nFirst As Long, nCodePolyGen As Integer
    Dim sDecodedMessage As String, sDM As String, sChannelRx As String, sChannelTx As String, sEdges As String
    Dim sCodedMessage As String, sMessage As String, sMW As String, sFctr As String, vT As Variant
    
    On Error GoTo ErrorHandler
    
UserSettings:
    ' Set sheet 1 for output as text
    ' worksheet will be cleared and overwritten between runs
    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    ' format sheet cells
    With oSht.Columns
        .NumberFormat = "@"
        .Font.Size = 16
    End With
    oSht.Cells(1, 1).Select
    
    ' ================================================================================================================
    ' ===========================MODE NUMBER DESCRIPTIONS=============================================================
    
    ' MODE 1
    ' manual coder input- type string into variable sMessage
    ' manual decoder input errors-typed into array variable list vEM
    
    ' MODE 2
    ' manual coder input- type string into variable sMessage
    ' regular spacing of errors throughout, set gap between two errors
    ' in nClearErrGap and start position for first in nFirst
    
    ' MODE 3
    ' manual coder input- type string into variable sMessage
    ' one pair of errors only, gap between two errors is random and start
    ' position for first is set with nFirst- adjusts to input length
    
    ' MODE 4
    ' manual coder input- type string into variable sMessage
    ' auto decoder input errors- random errors with BER (bit error rate)
    ' set in sngBER
    
    ' MODE 5
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' manual decoder input errors-typed into array variable list vEM
    
    ' MODE 6
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' regular spacing of errors throughout, set gap between two errors in
    ' nClearErrGap and start position for first in nFirst
    
    ' MODE 7
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' one pair of errors only, gap between two errors is random and start
    ' position for first is set with nFirst- adjusts to input length
    
    ' MODE 8
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' auto decoder input errors- random errors with BER (bit error rate)
    ' set in sngBER
    
    ' MODE 9
    ' manual coder input- type string into variable sMessage
    ' no errors at all - no need to touch error settings
    ' -goes round error insertion
    
    ' MODE 10
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' no errors at all - no need to touch error settings
    ' -goes round error insertion
    
    ' ================================================================================================================
    ' ===========================SET WORKING MODE HERE================================================================
    nCodePolyGen = 76                ' options so far are 76 for (2,1,3)(111,110) or 75 for (2,1,3)(111,101)
    nModeNumber = 1                  ' see meanings above
    
    ' ================================================================================================================
    ' ===========================COMMON PARAMETERS====================================================================
    
    nAutoCycles = 1                  ' set the number of cycles to run
    nCycleToDisplay = nAutoCycles    ' choose the cycle number for the metrics sheet output
    
    ' ================================================================================================================
    ' ===========================RANDOM INPUT BLOCK LENGTH============================================================
    
    ' USER SET BIT LENGTH FOR INPUT TO CODER - THE MESSAGE INPUT
    nLenAutoInput = 20                ' there will be double this number at decoder input
    
    ' ================================================================================================================
    ' ===========================MANUAL INPUT SETTINGS================================================================
    
    sMessage = "10110" ' for the Wiki page example
    
    ' sMessage = "10000"               ' gives impulse response 11  10  11 ...00  00  00 for 7,5
    ' sMessage = "10000"               ' gives impulse response 11  11  10 ...00  00  00 for 7,6
    ' =================================================================================================================
    ' ===========================SET BER, POSITIONS AND GAPS===========================================================
    
    nClearErrGap = 5      ' modes 2,3,7,and 6 to set an error gap
    nNumCdrFlushBits = 2  ' modes 2,3,4,6,7,and 8 to apply message end flushing
    sngBER = 0.1        ' modes 4 and 8 to insert specified bit error rate at decoder input
    nFirst = 5            ' modes 2,3,6,and 7 to set the first error position at decoder input
    
    ' =================================================================================================================
    ' ===========================MANUALLY SET ERROR PARAMETERS=========================================================
    
    ' MANUALLY SET ERROR POSITIONS - arrange list in increasing order. Applies at decoder input
    ' vEM = Array(21, 28, 35, 42, 49, 56, 62)     'for (7,6). Single errors with gaps of 6 error free bits
    ' vEM = Array(21, 27, 33, 39, 45, 52, 59)     'for (7,5). Single errors with gaps of 5 error free bits
    ' vEM = Array(21, 22, 36, 37, 52, 53, 68, 69) 'for (7,5). 4 double errors with gaps around 12 error free bits
    ' vEM = Array(20, 21)
    vEM = Array(3, 9)
    
    ' =================================================================================================================
    ' =================================================================================================================
WORKING:
    
    ' CYCLE COUNT DISPLAY SPECIFIC OVERRIDES
    Select Case nModeNumber
    Case 1, 2, 9
        nAutoCycles = 1  ' some modes need only single cycle
        nCycleToDisplay = 1
    End Select
    
    Application.DisplayStatusBar = True
    
    ' RUN A SPECIFIED NUMBER OF CYCLES
    For r = 1 To nAutoCycles
        DoEvents    ' interrupt to handle system requests
        Application.StatusBar = (r * 100) \ nAutoCycles & " Percent complete"
        
        ' CODE the message stream
        ' Decide how input is produced for each mode
        ' and add three zeros for FLUSHING
        Select Case nModeNumber
        Case 1, 2, 3, 4, 9
            If Len(sMessage) < 2 Then MsgBox "Manual input string sMessage is too short - closing": Exit Sub
            sMW = sMessage & String(nNumCdrFlushBits, "0") ' manually typed message into an array list
        Case 5, 6, 7, 8, 10
            If nLenAutoInput < 2 Then MsgBox "Short string length specified -closing": Exit Sub
            sMW = AutoRandomInputC(nLenAutoInput) & String(nNumCdrFlushBits, "0") ' auto random message
        End Select
        
        ' CODER
        ' obtain a coded message from the input
        Select Case nCodePolyGen
        Case 76
            ConvolutionalCoderT7B6C sMW, sCodedMessage
        Case 75
            ConvolutionalCoderT7B5C sMW, sCodedMessage
        Case Else
            MsgBox "Chosen algorithm not found - closing"
            Exit Sub
        End Select
        sChannelTx = sCodedMessage
        
        ' check that manual error selection will fit the stream
        ' auto errors have own checks
        Select Case nModeNumber
        Case 1, 5
            LB1 = LBound(vEM, 1): UB1 = UBound(vEM, 1)
            ' check whether positions are possible
            For x = LB1 To UB1
                If vEM(x) > (2 * Len(sMW)) Then
                    MsgBox "Manually selected bit positions don't fit the stream." & vbCrLf & _
                    "Increase input length or change the bit positions." & vbCrLf & _
                    "Closing."
                    Exit Sub
                End If
            Next x
        End Select
        
        ' ERRORS
        ' ADD ERRORS to sChannelTX to simulate channel noise
        ' Decide how errors are inserted for each mode
        Select Case nModeNumber
        Case 1, 5   ' manual error assignment
            sChannelRx = AddFixedErrsC(sChannelTx, vEM)
        Case 2, 6   ' two error spacing, manual gap and start
            sChannelRx = FixedSpacedErrorsC(sChannelTx, nFirst, nClearErrGap, 0)
        Case 3, 7   ' two errors only, random gap and manual start
            sChannelRx = TwoErrOnlyRndGapC(sChannelTx, nFirst, 0)
        Case 4, 8   ' auto random errors to manual BER setting
            sChannelRx = InsertBERRndC(sChannelTx, sngBER, 0)
        Case 9, 10  ' no errors at all
            sChannelRx = sChannelTx
        End Select
        
        ' DECODER
        ' DECODE the errored bit stream - proc uses Viterbi algorithm
        Select Case nCodePolyGen
        Case 76
            ConvolutionalDecodeC sChannelRx, sDecodedMessage, sEdges, bLucky, 76, vArr, vT
        Case 75
            ConvolutionalDecodeC sChannelRx, sDecodedMessage, sEdges, bLucky, 75, vArr, vT
        Case Else
            MsgBox "Configuration not defined - 75 or 76 only - closing"
            Exit Sub
        End Select
        sDM = sDecodedMessage
        
        ' SELECTIVE DISPLAY FOR SHEET - display for any ONE cycle
        If Application.ScreenUpdating = True Then Application.ScreenUpdating = False
        If r = nCycleToDisplay And nCycleToDisplay <> 0 Then
            oSht.Activate
            oSht.Cells.ClearContents             'remove text
            oSht.Cells.Interior.Pattern = xlNone 'remove color fill
            ' chosen run metrics to sheet
            For rd = LBound(vArr, 2) To UBound(vArr, 2)
                For cd = LBound(vArr, 1) To UBound(vArr, 1)
                    oSht.Cells(rd, cd + 1) = CStr(vArr(cd, rd))
                Next cd
            Next rd
            With oSht ' block in unused nodes and add notes
                .Cells(1, 1) = "0"
                .Cells(2, 1) = "*"
                .Cells(3, 1) = "*"
                .Cells(4, 1) = "*"
                .Cells(2, 2) = "*"
                .Cells(4, 2) = "*"
                .Cells(12, 1) = "Notes:": .Cells(12, 2) = "Currently using (" & nCodePolyGen & ") configuration."
                .Cells(13, 1) = "m:"
                .Cells(14, 1) = "c:"
                .Cells(15, 1) = "r:"
                .Cells(16, 1) = "r*:"
                .Cells(17, 1) = "m*:"
                .Cells(13, 2) = "The original message stream:"
                .Cells(14, 2) = "The coded output stream:"
                .Cells(15, 2) = "The coded output with any channel errors in magenta:"
                .Cells(16, 2) = "The back path edge values:"
                .Cells(17, 2) = "The recovered message with any remaining errors in red:"
                .Cells(18, 2) = "The decoder back path is shown in yellow:"
            End With
            oSht.Range(Cells(13, 2), Cells(18, 2)).Font.Italic = True
            
            DigitsToSheetRowC sMW, 1, 6, "m"               ' message in
            DigitsToSheetRowC sChannelTx, 2, 7, "c"        ' correctly coded message
            DigitsToSheetRowC sChannelRx, 2, 8, "r"        ' coded message as received
            DigitsToSheetRowC sEdges, 2, 9, "r*"           ' back path edge values
            DigitsToSheetRowC sDecodedMessage, 1, 10, "m*" ' message out
            
            ' tint the back path cells
            For cd = LBound(vT, 1) To UBound(vT, 1)
                ' MsgBox vT(cd, 1) & " " & vT(cd, 2)
                oSht.Cells(vT(cd, 1), vT(cd, 2) + 1).Interior.Color = RGB(249, 216, 43) ' yellow-orange
            Next cd
        End If
        
        ' IN-LOOP DATA COLLECTION
        ' ACCUMULATE DATA across all cycles
        nMErr = NumBitsDifferentC(sMW, sDM, nLenStream)                ' message errors single cycle
        nDErr = NumBitsDifferentC(sChannelRx, sChannelTx, nLenIntoDec) ' num decoder input errors single cycle
        nTotLenStream = nTotLenStream + nLenStream                    ' accum num message bits all cycles
        nTotMErr = nTotMErr + nMErr                                   ' accum num message error bits all cycles
        nTotDIErr = nTotDIErr + nDErr                                 ' accum num decoder input errors all cycles
        
        ' reset cycle error counters
        nDErr = 0: nDErr = 0
    Next r ' end of main cycle counter
    
Transfers:
    
    ' HIGHLIGHT ERRORS ON WORKSHEET - message bit errors red, changes to back path magenta
    ColourTheErrors Len(sMW) 'colours length of input block plus flushing    
    
    ' PREPARE ALL-CYCLE SUMMARY
    nTotMBSent = nTotLenStream                               ' accum num message bits all cycles
    nTotEBMess = nTotMErr                                    ' accum num message err bits all cycles
    nNumDEPC = nTotDIErr / nAutoCycles                       ' num input errors added decoder input each cycle
    sngBerDecIn = Round(nTotDIErr / (nTotMBSent * 2), 10)    ' channel BER decoder input all cycles
    sngBerMOut = Round(nTotEBMess / nTotMBSent, 10)          ' message BER decoder output all cycles
    If sngBerMOut = 0 Then
        sFctr = "Perfect"
    Else
        sFctr = Round(sngBerDecIn / sngBerMOut, 1)           ' BER improvement across decoder
    End If
    
    ' OUTPUT SUMMARY
    MsgBox "Total of all message bits sent   : " & nTotMBSent & vbCrLf & _
    "Total errored bits in all received messages   : " & nTotEBMess & vbCrLf & _
    "Number channel errors per cycle   : " & nNumDEPC & " in block lengths of   : " & nLenIntoDec & vbCrLf & _
    "BER applied over all decoder input   : " & sngBerDecIn & " : " & sngBerDecIn * 100 & "%" & vbCrLf & _
    "BER for all messages out of decoder   : " & sngBerMOut & " : " & sngBerMOut * 100 & "%" & vbCrLf & _
    "Improvement factor across decoder   : " & sFctr
    
    ' RESETS
    If Application.ScreenUpdating = False Then Application.ScreenUpdating = True
    Application.StatusBar = ""
    
    Exit Sub
    
ErrorHandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
        Case 13 ' early exit for certain settings mistakes
            Err.Clear
            Exit Sub
        Case Else
            MsgBox "Error number: " & Err.Number & vbNewLine & _
            "Error source: " & Err.Source & vbNewLine & _
            "Description: " & Err.Description & vbNewLine
            Err.Clear
            Exit Sub
        End Select
    End If
End Sub

Function ConvolutionalCoderT7B5C(ByVal sInBitWord As String, sOut As String)
    ' rate 1/2 coder; one bit in leads to two bits out
    ' 3 register equivalent, constraint 3
    ' generator polynomials are top = (1,1,1) and bottom = (1,0,1)
    ' taken for output first top then bottom
    
    Dim x0 As Long, x1 As Long, x2 As Long
    Dim sOut7 As String, sOut5 As String
    Dim n As Long, sOutBitWord As String
    
    If sInBitWord = "" Or Len(sInBitWord) < 5 Then
        MsgBox "Longer input required for ConvolutionalCoder - closing"
        Exit Function
    End If
    
    ' itialise all registers with zeros
    x0 = 0: x1 = 0: x2 = 0
    
    ' run the single input bits through the shift register
    For n = 1 To Len(sInBitWord) ' this includes any flushing bits
        DoEvents
        ' shift in one bit
        x2 = x1                          ' second contents into third position
        x1 = x0                          ' first contents into second position
        x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first
        
        ' combine register outputs
        sOut7 = x0 Xor x1 Xor x2         ' top adder output
        sOut5 = x0 Xor x2                ' bottom adder output
        
        ' combine and accumulate two adder results
        sOutBitWord = sOutBitWord & sOut7 & sOut5
        sOut = sOutBitWord
    Next n
    
End Function

Function ConvolutionalCoderT7B6C(ByVal sInBitWord As String, sOut As String)
    ' rate 1/2 coder; one bit in leads to two bits out
    ' 3 register equivalent, constraint 3
    ' generator polynomials are top = (1,1,1) and bottom = (1,1,0)
    ' taken for output first top then bottom
    
    Dim x0 As Long, x1 As Long, x2 As Long
    Dim sOut7 As String, sOut6 As String
    Dim n As Long, sOutBitWord As String
    
    If sInBitWord = "" Or Len(sInBitWord) < 5 Then
        MsgBox "Longer input required for ConvolutionalCoder - closing"
        Exit Function
    End If
    
    ' itialise all registers with zeros
    x0 = 0: x1 = 0: x2 = 0
    
    ' run the single input bits through the shift register
    For n = 1 To Len(sInBitWord) ' this includes any flushing bits
        DoEvents
        ' shift in one bit
        x2 = x1                          ' second contents into third position
        x1 = x0                          ' first contents into second position
        x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first
        
        ' combine register outputs
        sOut7 = x0 Xor x1 Xor x2         ' top adder output
        sOut6 = x0 Xor x1                ' bottom adder output
        
        ' combine and accumulate two adder results
        sOutBitWord = sOutBitWord & sOut7 & sOut6
        sOut = sOutBitWord
    Next n
    
End Function

Function FixedSpacedErrorsC(ByVal sIn As String, ByVal nStart As Long, ByVal nErrFreeSpace As Long, _
    nTail As Long, Optional nErrCount As Long) As String
    
    ' returns parameter input string in function name with errors added
    ' at fixed intervals, set by nERRFreeSpace, the error free space between errors,
    ' and sequence starts with positon nStart.   Total number of errors placed is found in option parameter nErrCount
    ' nTail is the number of end bits to keep clear of errors.
    
    Dim n As Long, nLen As Long, nWLen As Long, sAccum As String, c As Long, sSamp As String, nModBit As Long
    
    ' check for an empty input string
    If sIn = "" Then
        MsgBox "Empty string input in FixedSpacedErrors - closing"
        Exit Function
    End If
    
    ' get length of input less tail piece
    nWLen = Len(sIn) - nTail
    
    ' check length of input sufficient for parameters
    If nWLen - nStart < nErrFreeSpace + 1 Then
        MsgBox "Input too short in FixedSpacedErrors - increase length -closing"
        Exit Function
    End If
    
    ' accum the part before the start error
    sAccum = Mid$(sIn, 1, nStart - 1)
    
    ' modify the bit in start position and accum result
    sSamp = Mid$(sIn, nStart, 1)
    nModBit = CLng(sSamp) Xor 1
    sAccum = sAccum & CStr(nModBit)
    nErrCount = 1      ' count one error added
    
    ' insert fixed interval errors thereafter
    For n = nStart + 1 To nWLen
        sSamp = Mid$(sIn, n, 1)
        c = c + 1
        If c = nErrFreeSpace + 1 And n <= nWLen Then ' do the stuff
            c = 0
            nModBit = CLng(sSamp Xor 1)
            sAccum = sAccum & CStr(nModBit)
            nErrCount = nErrCount + 1
        Else
            sAccum = sAccum & sSamp
        End If
    Next n
    
    FixedSpacedErrorsC = sAccum
    
End Function

Function TwoErrOnlyRndGapC(ByVal sIn As String, ByVal nStart As Long, ByVal nTail As Long) As String
    ' returns input string in function name with only 2 added errors, the first at parameter position and
    ' the second after a random gap.
    ' nTail is the number of end bits to keep clear of errors.
    
    Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long
    Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String
    
    ' find length free of tail bits
    nRange = Len(sIn) - nTail
    
    ' check that sIn is long enough
    If nRange < nStart + 1 Then
        MsgBox "sIn too short for start point in TwoErrOnlyRndGap - closing"
        Exit Function
    End If
    
    ' set number of errors needed
    nReqNumErr = 2 ' one start and one random
    
    ' dimension an array to hold the work
    ReDim vA(1 To Len(sIn), 1 To 3)
    
    ' load array col 1 with the input bits
    ' and mark the start bit for error
    For r = LBound(vA, 1) To UBound(vA, 1)
        vA(r, 1) = CLng(Mid$(sIn, r, 1))
        If r = nStart Then ' mark start bit with flag
            vA(r, 2) = 1
        End If
    Next r
    
    ' mark intended positions until right number of
    ' non-overlapping errors is clear
    Do Until nCount = nReqNumErr
        nCount = 0 ' since first err in place
        DoEvents
        ' get a sample of row numbers in the working range
        nSample = Int((nRange - (nStart + 1) + 1) * Rnd + (nStart + 1))
        ' error flag added to col 2 of intended row
        vA(nSample, 2) = 1 ' 1 denotes intention
        
        ' run through array col 1
        For c = LBound(vA, 1) To UBound(vA, 1)
            ' count all intention markers so far
            If vA(c, 2) = 1 Then
                nCount = nCount + 1
            End If
        Next c
    Loop
    
    ' when num errors is right modify the ones flagged
    For r = LBound(vA, 1) To UBound(vA, 1)
        sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2))
    Next r
    
    TwoErrOnlyRndGapC = sAccum
    
End Function

Function AddFixedErrsC(ByVal sIn As String, vA As Variant) As String
    ' returns string in function name with errors added in fixed positions.
    ' positions are set by one dimensional list in vA array
    
    Dim c As Long, nPosition As Long, UB1 As Long, LB1 As Long
    Dim sSamp As String, sWork As String, sSamp2 As String, sAccum As String
    
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
    
    sWork = sIn
    For nPosition = LB1 To UB1 ' 0 to 2 eg
        For c = 1 To Len(sWork)
            sSamp = Mid$(sWork, c, 1)
            If c = vA(nPosition) Then
                sSamp2 = (1 Xor CLng(sSamp))
                sAccum = sAccum & sSamp2
            Else
                sAccum = sAccum & sSamp
            End If
        Next c
        sWork = sAccum
        sAccum = ""
    Next nPosition
    
    AddFixedErrsC = sWork
    
End Function

Function InsertBERRndC(ByVal sIn As String, ByVal BER As Single, ByVal nTail As Long) As String
    ' returns input string of bits with added random errors in function name
    ' number of errors depends on length of sIn and BER parameter
    ' Set nTail to zero to apply errors to flushing bits too
    
    Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long
    Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String
    
    ' find length free of nTail eg, remove flushing
    nRange = Len(sIn) - nTail
    
    ' find number of errors that are needed
    nReqNumErr = CLng(BER * nRange) ' Clng rounds fractions
    If nReqNumErr < 1 Then
        MsgBox "Requested error rate produces less than one error in InsertBERRnd" & vbCrLf & _
        "Increase stream length, or reduce BER, or both - closing"
        Exit Function
    End If
    
    ' dimension an array to hold the work
    ReDim vA(1 To Len(sIn), 1 To 3)
    
    ' load array col 1 with the input bits
    For r = LBound(vA, 1) To UBound(vA, 1)
        vA(r, 1) = CLng(Mid$(sIn, r, 1))
    Next r
    
    ' mark intended positions until right number of
    ' non-overlapping errors is clear
    Do Until nCount = nReqNumErr
        nCount = 0
        DoEvents
        ' get a sample of row numbers in the working range
        nSample = Int((nRange - 1 + 1) * Rnd + 1)
        ' error flag added to col 2 of intended row
        vA(nSample, 2) = 1 ' 1 denotes intention
        
        ' run through array col 1
        For c = LBound(vA, 1) To UBound(vA, 1)
            ' count all intention markers so far
            If vA(c, 2) = 1 Then
                nCount = nCount + 1
            End If
        Next c
    Loop
    
    ' when num errors is right modify the ones flagged
    For r = LBound(vA, 1) To UBound(vA, 1)
        sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2))
    Next r
    
    InsertBERRndC = sAccum
    
End Function

Sub ConvolutionalDecodeC(ByVal sIn As String, sOut As String, sOut2 As String, bAmbiguous As Boolean, _
                         nConfiguration As Long, vRet As Variant, vTint As Variant)
    ' works with rate 1/2 coder; one bit in leads to two bits out
    ' 3 register equivalent, constraint 3, generator polynomials are top = (1,1,1) and bottom = (1,1,0) for 7,6
    ' and (1,1,1) and (1,0,1) for 7,5, selected by parameter nConfiguration= 75 or 76.
    
    ' NOTES: All calculations of metrics use maximum closeness as opposed to Hamming distance.
    '       In branch estimates the lowest total is always discarded.
    '       If branch metrics are equal, discard the bottom of the two incoming branches.
    '       Working for metrics assumes position at node with two incoming branches.
    '       Back track starts at last column's metric maximum then follows survivor paths
    '       back to state "a" time zero.
    
    Dim aV() As String, vH As Variant, sWIn As String, sPrevStateAccumL As String, sPrevStateAccumU As String
    Dim nStartR As Long, nStartC As Long, sEdgeBits As String, sInputBit As String
    Dim r As Long, c As Long, nSwapR As Long, nSwapC As Long
    Dim nVert As Long, nTime As Long, bUpperPath As Boolean, vW As Variant
    Dim sAccumEdgeValues As String, sAccumImpliesBits As String
    Dim sCurrState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, sLSOut As String
    Dim sBitU As String, sBitL As String, sRcdBits As String, nNumTrans As Long
    Dim sProposedAccumU As String, sProposedAccumL As String, sDiscardedU As String, sDiscardedL As String
    Dim sNodeAccum As String, sBackStateU As String, sBackStateL As String, nNumHighs As Long
    
    ' check that number received is even
    sWIn = sIn
    If Len(sWIn) Mod 2 = 0 Then
        nNumTrans = Len(sWIn) / 2
    Else
        MsgBox "Odd bit pairing at input decoder -closing"
        Exit Sub
    End If
    
    ' dimension arrays
    Erase aV()
    ReDim aV(0 To nNumTrans, 1 To 4, 1 To 3)  ' x transitions, y states, z node data
    ReDim vH(1 To 4, 1 To 3)                  ' r states, c node data
    ReDim vW(0 To nNumTrans, 1 To 4)          ' r transitions, c states
    ReDim vTint(0 To nNumTrans, 1 To 2)
    aV(0, 1, 3) = "0"                         ' set metric for zero node
    
    ' CYCLE LOOP
    For nTime = 1 To nNumTrans
        For nVert = 1 To 4
            DoEvents
            
            ' Get incoming branch data for current node
            If nConfiguration = 75 Then
                GeneralDataT7B5C nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL
            ElseIf nConfiguration = 76 Then
                GeneralDataT7B6C nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL
            End If
            
            ' Get the received bits for the incoming transition
            sRcdBits = Mid$(sWIn, (nTime * 2) - 1, 2)
            
            ' get the current node's previous states' metrics
            If sCurrState = "a" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3)
            If sCurrState = "a" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3)
            If sCurrState = "b" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3)
            If sCurrState = "b" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3)
            If sCurrState = "c" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3)
            If sCurrState = "c" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3)
            If sCurrState = "d" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3)
            If sCurrState = "d" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3)
            
            ' NOTE ON EXCEPTIONS
            ' Exceptions for transitions 0, 1 and 2.  Some redundant, or fewer than two incoming branches.
            ' Nodes with single incoming branches; mark blind branches same edge value as existing edge,
            ' and mark their previous metrics as zeros.  Because policy for choosing equal metrics is always
            ' to discard the bottom one, exceptions can then be handled in same loop.
            ' Zero column is handled entirely by settings for transition 1.
            
            ' Apply exceptions settings
            If nConfiguration = 75 Then
                FrontExceptions75C nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
            ElseIf nConfiguration = 76 Then
                FrontExceptions76C nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
            End If
            
            ' Calculate incoming branch metrics and add their previous path metrics to each
            sProposedAccumU = GetProposedAccumC(sRcdBits, sUSOut, sPrevStateAccumU)
            sProposedAccumL = GetProposedAccumC(sRcdBits, sLSOut, sPrevStateAccumL)
            
            ' Decide between the two proposed metrics for the current node
            ' Accept the higher value branch metric and discard the other
            ' If same in value, choose the top branch and discard the bottom.
            If CLng(sProposedAccumU) > CLng(sProposedAccumL) Then
                sDiscardedL = "Discard": sDiscardedU = "Keep"
                sNodeAccum = sProposedAccumU
            ElseIf CLng(sProposedAccumU) < CLng(sProposedAccumL) Then
                sDiscardedL = "Keep": sDiscardedU = "Discard"
                sNodeAccum = sProposedAccumL
            ElseIf CLng(sProposedAccumU) = CLng(sProposedAccumL) Then
                sDiscardedL = "Discard": sDiscardedU = "Keep"
                sNodeAccum = sProposedAccumU
            End If
            
            ' Update the node array with the discard data
            aV(nTime, nVert, 1) = sDiscardedU  ' whether or not upper incoming discarded
            aV(nTime, nVert, 2) = sDiscardedL  ' whether or not lower incoming discarded
            
            ' Update the node array with the value of path metric for the current node
            aV(nTime, nVert, 3) = sNodeAccum   ' update work array with metric
            
            ' Update return work array with node metric value
            vW(nTime, nVert) = CLng(sNodeAccum) ' update return display array with metric
            
        Next nVert
    Next nTime
    
    ' Transfer last column metric values to a work array
    c = nNumTrans                      ' the last column number
    For r = 1 To 4                     ' number of rows in every column
        vH(r, 1) = CLng(aV(c, r, 3))   ' metrics
        vH(r, 2) = CLng(c)             ' column where metric found in main array
        vH(r, 3) = CLng(r)             ' row where metric found in main array
    Next r
    
    ' Sort the last column values to place highest metric at top
    SortMetricsArr2D1KeyC vH, 0, 1, 1        ' and assoc recs are in same row
    
    ' Detect start point ambiguity for possible future use
    ' Count number of entries with same high value in column
    nNumHighs = 0
    For r = 1 To 4   ' number rows in every column
        If vH(1, 1) = vH(r, 1) Then nNumHighs = nNumHighs + 1
    Next r
    If nNumHighs > 1 Then bAmbiguous = True
    
    ' Note the row and column numbers for the back path start point
    nStartR = CLng(vH(1, 3))               ' retrieve row number
    nStartC = CLng(vH(1, 2))               ' retrieve col number
    
    ' add coordinates to vTint
    vTint(nStartC, 1) = nStartR
    vTint(nStartC, 2) = nStartC
    
    ' BACK PATH
    ' Navigate the back path and extract its data
    Do Until nStartC <= 0
        DoEvents  ' allow system requests
        
        ' Find survivor path into this node
        ' if upperpath is open...
        If aV(nStartC, nStartR, 1) = "Keep" Then bUpperPath = True Else bUpperPath = False
        ' if lower path is open...
        If aV(nStartC, nStartR, 2) = "Keep" Then bUpperPath = False Else bUpperPath = True
        
        ' Get present state
        sCurrState = GetStateFmRowC(nStartR)
        
        ' Use present state name to fetch the output bits
        If nConfiguration = 75 Then
            GetOutputBitsT7B5C sCurrState, bUpperPath, sEdgeBits, sInputBit
        ElseIf nConfiguration = 76 Then
            GetOutputBitsT7B6C sCurrState, bUpperPath, sEdgeBits, sInputBit
        Else
            MsgBox "Configuration not defined"
        End If
        
        ' Accumulate output and input values for hop
        sAccumEdgeValues = sEdgeBits & sAccumEdgeValues    ' edge values -not used
        sAccumImpliesBits = sInputBit & sAccumImpliesBits  ' decoded message -used
        
        ' Get array coordinates for next node in back path
        If nConfiguration = 75 Then
            GetPosOfSourceT7B5C nStartR, nStartC, bUpperPath, nSwapR, nSwapC
        ElseIf nConfiguration = 76 Then
            GetPosOfSourceT7B6C nStartR, nStartC, bUpperPath, nSwapR, nSwapC
        Else
            MsgBox "Configuration not defined"
        End If
        
        ' Update the new position coordinates for the next hop
        nStartR = nSwapR
        nStartC = nSwapC
        
        ' add coordinates to vTint
        vTint(nStartC, 1) = nStartR
        vTint(nStartC, 2) = nStartC
        
    Loop
    
Transfers:
    
    ReDim vRet(LBound(vW, 1) To UBound(vW, 1), LBound(vW, 2) To UBound(vW, 2))
    vRet = vW
    sOut = sAccumImpliesBits 'single bit message from back path
    sOut2 = sAccumEdgeValues 'double bit back path edge outputs
    
End Sub

Function GetStateFmRowC(nRow As Long) As String
    ' returns alpha name of state for parameter
    ' row position in trellis column
    
    Select Case nRow
    Case 1
        GetStateFmRowC = "a"
    Case 2
        GetStateFmRowC = "b"
    Case 3
        GetStateFmRowC = "c"
    Case 4
        GetStateFmRowC = "d"
    End Select
    
End Function

Function FrontExceptions75C(ByVal nT As Long, ByVal nV As Long, _
    sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean
    ' applies the exceptions for configuration 7,5 - applies to closeness only
    
    If nT = 1 And nV = 1 Then
        sLSO = "00": sUSO = "00": sPSAL = "0": sPSAU = "0"
    ElseIf nT = 1 And nV = 3 Then
        sLSO = "11": sUSO = "11": sPSAL = "0": sPSAU = "0"
    ElseIf nT = 2 And nV = 1 Then
        sLSO = "00": sUSO = "00": sPSAL = "0"
    ElseIf nT = 2 And nV = 2 Then
        sLSO = "10": sUSO = "10": sPSAL = "0"
    ElseIf nT = 2 And nV = 3 Then
        sLSO = "11": sUSO = "11": sPSAL = "0"
    ElseIf nT = 2 And nV = 4 Then
        sLSO = "01": sUSO = "01": sPSAL = "0"
    End If
    
    FrontExceptions75C = True
    
End Function

Function FrontExceptions76C(ByVal nT As Long, ByVal nV As Long, _
    sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean
    ' applies the exceptions for configuration 7,5 -applies to closeness only
    
    If nT = 1 And nV = 1 Then
        sLSO = "00": sUSO = "00": sPSAL = "0": sPSAU = "0"
    ElseIf nT = 1 And nV = 3 Then
        sLSO = "11": sUSO = "11": sPSAL = "0": sPSAU = "0"
    ElseIf nT = 2 And nV = 1 Then
        sLSO = "00": sUSO = "00": sPSAL = "0" ' arbitrarily high
    ElseIf nT = 2 And nV = 2 Then
        sLSO = "11": sUSO = "11": sPSAL = "0"
    ElseIf nT = 2 And nV = 3 Then
        sLSO = "11": sUSO = "11": sPSAL = "0"
    ElseIf nT = 2 And nV = 4 Then
        sLSO = "00": sUSO = "00": sPSAL = "0"
    End If
    
    FrontExceptions76C = True
    
End Function

Function SortMetricsArr2D1KeyC(ByRef vA As Variant, _
    Optional ByVal bIsAscending As Boolean = True, _
    Optional ByVal bIsRowSort As Boolean = True, _
    Optional ByVal SortIndex As Long = -1, _
    Optional ByRef vRet As Variant) As Boolean
    ' --------------------------------------------------------------------------------
    ' Procedure : Sort2DArr
    ' Purpose   : Bubblesorts a 2D array on 1 key, up or down, on any column or row.
    '             Options include in-place, with the source changed, or
    '             returned in vRet, with the source array intact.
    '             Optional parameters default to: ROW SORT in place, ASCENDING,
    '             using COLUMN ONE as the key.
    ' --------------------------------------------------------------------------------
    
    Dim condition1 As Boolean, vR As Variant
    Dim i As Long, j As Long, y As Long, t As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim bWasMissing As Boolean
    
    ' find bounds of vA data input array
    loR = LBound(vA, 1): hiR = UBound(vA, 1)
    loC = LBound(vA, 2): hiC = UBound(vA, 2)
    
    ' find whether optional vR was initially missing
    bWasMissing = IsMissing(vRet)
    ' If Not bWasMissing Then Set vRet = Nothing
    
    ' check input range of SortIndex
    If bIsRowSort And (SortIndex < loC Or SortIndex > hiC) Then
        MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
        Exit Function
    Else:
    End If
    
    If Not bIsRowSort And (SortIndex < loR Or SortIndex > hiR) Then
        MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
        Exit Function
    Else:
    End If
    
    ' pass to a work variable
    vR = vA
    
    ' steer input options
    If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
    
ROWSORT:
    For i = loR To hiR - 1
        For j = loR To hiR - 1
            If bIsAscending Then
                condition1 = vR(j, SortIndex) > vR(j + 1, SortIndex)
            Else
                condition1 = vR(j, SortIndex) < vR(j + 1, SortIndex)
            End If
            If condition1 Then
                For y = loC To hiC
                    t = vR(j, y)
                    vR(j, y) = vR(j + 1, y)
                    vR(j + 1, y) = t
                Next y
            End If
        Next
    Next
    GoTo Transfers
    
COLSORT:
    For i = loC To hiC - 1
        For j = loC To hiC - 1
            If bIsAscending Then
                condition1 = vR(SortIndex, j) > vR(SortIndex, j + 1)
            Else
                condition1 = vR(SortIndex, j) < vR(SortIndex, j + 1)
            End If
            If condition1 Then
                For y = loR To hiR
                    t = vR(y, j)
                    vR(y, j) = vR(y, j + 1)
                    vR(y, j + 1) = t
                Next y
            End If
        Next
    Next
    GoTo Transfers
    
Transfers:
    ' decide whether to return in vA or vRet
    If Not bWasMissing Then
        ' vRet was the intended return array
        ' so return vRet leaving vA intact
        vRet = vR
    Else:
        ' vRet is not intended return array
        ' so reload vA with vR
        vA = vR
    End If
    
    ' set return function value
    SortMetricsArr2D1KeyC = True
    
End Function

Function GeneralDataT7B5C(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _
    sLSOut As String, sBitU As String, sBitL As String) As Boolean
    ' takes as input nVert as position in trellis column and returns various data for that state
    
    Select Case nVert
    Case 1
        sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "11": sBitU = "0": sBitL = "0"
    Case 2
        sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "10": sLSOut = "01": sBitU = "0": sBitL = "0"
    Case 3
        sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "00": sBitU = "1": sBitL = "1"
    Case 4
        sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "01": sLSOut = "10": sBitU = "1": sBitL = "1"
    Case Else
    End Select
    
    GeneralDataT7B5C = True
    
End Function

Function GeneralDataT7B6C(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _
    sLSOut As String, sBitU As String, sBitL As String) As Boolean
    ' takes as input nVert as position in trellis column and returns various data for that state
    
    Select Case nVert
    Case 1
        sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "10": sBitU = "0": sBitL = "0"
    Case 2
        sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "11": sLSOut = "01": sBitU = "0": sBitL = "0"
    Case 3
        sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "01": sBitU = "1": sBitL = "1"
    Case 4
        sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "00": sLSOut = "10": sBitU = "1": sBitL = "1"
    Case Else
    End Select
    
    GeneralDataT7B6C = True
    
End Function

Function GetProposedAccumC(sRcd As String, sOut As String, sPrevStateAccum As String) As String
    ' returns one branch metric in function based on previous state metric, input, and edge value.
    
    Dim nBit As Long, n As Long, m As Long, nTemp As Long
    
    If sRcd = "" Then sRcd = "00"
    
    For n = 1 To 2
        nBit = CLng(Mid$(sOut, n, 1)) Xor CLng(Mid$(sRcd, n, 1))
        m = m + nBit
    Next n
    If sPrevStateAccum = "" Then sPrevStateAccum = "0"
    nTemp = Abs(m - 2) + CLng(sPrevStateAccum)
    
    GetProposedAccumC = CStr(nTemp)
    
End Function

Function GetOutputBitsT7B5C(sState As String, bUpper As Boolean, _
    sEdgeBits As String, sInputBit As String) As Boolean
    ' returns edge value and input given the alpha state name
    ' and choice of top or bottom branch.
    ' Applies to incoming branches joining at the node.
    
    Select Case sState
    Case "a"
        If bUpper = True Then
            sEdgeBits = "00"
            sInputBit = "0"
        Else
            sEdgeBits = "11"
            sInputBit = "0"
        End If
    Case "b"
        If bUpper = True Then
            sEdgeBits = "10"
            sInputBit = "0"
        Else
            sEdgeBits = "01"
            sInputBit = "0"
        End If
    Case "c"
        If bUpper = True Then
            sEdgeBits = "11"
            sInputBit = "1"
        Else
            sEdgeBits = "00"
            sInputBit = "1"
        End If
    Case "d"
        If bUpper = True Then
            sEdgeBits = "01"
            sInputBit = "1"
        Else
            sEdgeBits = "10"
            sInputBit = "1"
        End If
    End Select
    
    GetOutputBitsT7B5C = True
    
End Function

Function GetPosOfSourceT7B5C(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _
    nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean
    ' returns the array column and row for an incoming branch,
    ' given its position in trellis column and choice of top or bottom branch.
    
    Dim sNodesState As String
    
    ' convert to string state names
    Select Case nNodeR
    Case 1
        sNodesState = "a"
    Case 2
        sNodesState = "b"
    Case 3
        sNodesState = "c"
    Case 4
        sNodesState = "d"
    End Select
    
    ' for c=0 only
    If nNodeC = 0 Then
        MsgBox "No source beyond zero column"
        Exit Function
    End If
    
    ' For c>0 only
    Select Case sNodesState
    Case "a"
        If bUpper = True Then
            nEdgeSourceR = 1
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 2
            nEdgeSourceC = nNodeC - 1
        End If
    Case "b"
        If bUpper = True Then
            nEdgeSourceR = 3
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 4
            nEdgeSourceC = nNodeC - 1
        End If
    Case "c"
        If bUpper = True Then
            nEdgeSourceR = 1
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 2
            nEdgeSourceC = nNodeC - 1
        End If
    Case "d"
        If bUpper = True Then
            nEdgeSourceR = 3
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 4
            nEdgeSourceC = nNodeC - 1
        End If
    End Select
    
    GetPosOfSourceT7B5C = True
    
End Function

Function DigitsToSheetRowC(ByVal sIn As String, ByVal nNumGrp As Long, _
    ByVal nRow As Long, Optional ByVal sRLabel As String = "*")
    ' takes string of digits and an option code and distributes bits to worksheet rows
    
    Dim n As Long, c As Long, sSamp As String
    Dim oSht As Worksheet
    
    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    oSht.Activate
    
    If Len(sIn) Mod nNumGrp <> 0 Then
        MsgBox "Missing bits for grouping in  DigitsToSheetRow - closing"
        Exit Function
    End If
    
    c = 0
    ' 101 010 101 010
    For n = 1 To (Len(sIn) - nNumGrp + 1) Step nNumGrp
        DoEvents
        sSamp = Mid$(sIn, n, nNumGrp)
        c = c + 1
        oSht.Cells(nRow, c + 1) = sSamp
        If c >= 16384 Then Exit For
    Next n
    oSht.Cells(nRow, 1) = sRLabel
    
End Function

Sub ColourTheErrors(ByVal nLen As Long)
    ' colors specific data to show errors
    ' changes to decoder pairs in magenta
    ' changes between input and output message in red
    ' marks individual received bit errors in bold yellow
    ' marking is limited to 256 columns to accommodate Excel 2003

    Dim oSht As Worksheet, c As Long, nRow As Long

    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    oSht.Activate
    With oSht.Cells
       .Font.Color = RGB(0, 0, 0)
       .Font.Bold = False
    End With

    'clear colours in rows below first four to preserve backpath
    For nRow = 5 To 20
       oSht.Rows(nRow).Cells.Interior.Pattern = xlNone
    Next nRow

    For c = 2 To nLen + 1 'this is specified length of the string for display
        'Note that Excel versions have different max columns
        'Up to user to get it right eg: max 256 for Excel 2003
        'block with error colouring
        'message errors are in red
        If oSht.Cells(10, c) <> oSht.Cells(6, c) Then oSht.Cells(10, c).Interior.Color = vbRed
        'received channel errors magenta
        If oSht.Cells(7, c) <> oSht.Cells(8, c) Then oSht.Cells(8, c).Interior.Color = vbMagenta

        'individual errored character colouring in yellow within magenta block
        If Left(oSht.Cells(8, c).Value, 1) <> Left(oSht.Cells(7, c).Value, 1) Then
           With oSht.Cells(8, c).Characters(1, 1).Font
              .Color = -16711681
              .Bold = True
           End With
        End If

        If Right(oSht.Cells(8, c).Value, 1) <> Right(oSht.Cells(7, c).Value, 1) Then
          With oSht.Cells(8, c).Characters(2, 1).Font
             .Color = -16711681
             .Bold = True
          End With
        End If
    Next c

End Sub

Function GetOutputBitsT7B6C(sState As String, bUpper As Boolean, _
    sEdgeBits As String, sInputBit As String) As Boolean
    ' returns edge value and input given the alpha state name
    ' and choice of top or bottom branch.
    ' Applies to incoming branches joining at the node.
    
    Select Case sState
    Case "a"
        If bUpper = True Then
            sEdgeBits = "00"
            sInputBit = "0"
        Else
            sEdgeBits = "10"
            sInputBit = "0"
        End If
    Case "b"
        If bUpper = True Then
            sEdgeBits = "11"
            sInputBit = "0"
        Else
            sEdgeBits = "01"
            sInputBit = "0"
        End If
    Case "c"
        If bUpper = True Then
            sEdgeBits = "11"
            sInputBit = "1"
        Else
            sEdgeBits = "01"
            sInputBit = "1"
        End If
    Case "d"
        If bUpper = True Then
            sEdgeBits = "00"
            sInputBit = "1"
        Else
            sEdgeBits = "10"
            sInputBit = "1"
        End If
    End Select
    
    GetOutputBitsT7B6C = True
    
End Function

Function GetPosOfSourceT7B6C(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _
    nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean
    ' returns the array column and row for an incoming branch,
    ' given its position in trellis column and choice of top or bottom branch.
    
    Dim sNodesState As String
    
    ' convert to string state names
    Select Case nNodeR
    Case 1
        sNodesState = "a"
    Case 2
        sNodesState = "b"
    Case 3
        sNodesState = "c"
    Case 4
        sNodesState = "d"
    End Select
    
    ' for c=0 only
    If nNodeC = 0 Then
        MsgBox "No source beyond zero column"
        Exit Function
    End If
    
    ' For c>0 only
    Select Case sNodesState
    Case "a"
        If bUpper = True Then
            nEdgeSourceR = 1
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 2
            nEdgeSourceC = nNodeC - 1
        End If
    Case "b"
        If bUpper = True Then
            nEdgeSourceR = 3
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 4
            nEdgeSourceC = nNodeC - 1
        End If
    Case "c"
        If bUpper = True Then
            nEdgeSourceR = 1
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 2
            nEdgeSourceC = nNodeC - 1
        End If
    Case "d"
        If bUpper = True Then
            nEdgeSourceR = 3
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 4
            nEdgeSourceC = nNodeC - 1
        End If
    End Select
    
    GetPosOfSourceT7B6C = True
    
End Function

Function AutoRandomInputC(ByVal nLength As Long) As String
    ' makes a pseudo random string of parameter nLength
    
    Dim n As Long, sSamp As String, sAccum As String
    
    ' Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
    
    Randomize Timer
    For n = 1 To (nLength)
        sSamp = CStr(Int((1 - 0 + 1) * Rnd + 0))
        sAccum = sAccum & sSamp
    Next n
    
    AutoRandomInputC = sAccum
    
End Function

Function NumBitsDifferentC(ByVal sIn1 As String, ByVal sIn2 As String, Optional nLength As Long) As Long
    ' compares two binary strings of equal length
    ' and returns the count of the bits in function name that are different
    ' It is the Hamming distance between the two bit strings
    
    Dim nErr As Long, n As Long, m As Long
    
    ' check that streams are same length for comparison
    If Len(sIn1) <> Len(sIn2) Then
        MsgBox "Stream lengths do not match in StrDifference - closing"
        Exit Function
    End If
    
    ' 0 and  0 =   0
    ' 0 and  1 =   1
    ' 1 and  0 =   1
    ' 1 and  1 =   0
    
    For n = 1 To Len(sIn1)
        nErr = Abs(CLng(Mid$(sIn1, n, 1)) - CLng(Mid$(sIn2, n, 1)))
        m = m + nErr
    Next n
    
Transfers:
    nLength = Len(sIn1)
    NumBitsDifferentC = m
    
End Function

See Also[edit | edit source]

External Links[edit | edit source]


Viterbi Simulator in VBA 2

Summary[edit | edit source]

It has been noted that some calculate trellis metrics in different ways. So, this page includes an identical convolutional coding function to that in Viterbi Simulator in VBA. The main difference is that whereas that page displays its metrics in terms of CLOSENESS, this page does so in HAMMING DISTANCE. The code layout differs slightly between the two but the error correction remains the same.

This code is made for Excel. It simulates the behavior of a data channel's convolutional coding, though by necessity it concentrates on simple examples. Two rate 1/2 systems are provided; both with three stages, one for generator polynomial (111,110), and the other for (111,101). The code was written to improve understanding of the Wikibooks page A Basic Convolutional Coding Example, but might also be of elementary use for students without other software. The code concentrates on random errors of the type caused by Gaussian noise sources. Blank work sheets can be found in the drop-box below:

Blank Work Sheets for (7,5) and (7,6) Configurations
Viterbi Trellis Worksheet for configuration (7,6)
Viterbi Trellis Worksheet for configuration (7,5)


The Simulator[edit | edit source]

This simulator uses Hamming Distance to calculate its metrics.

For each of the two configurations, rudimentary options have been provided. No user form has been included here, the author preferring to modify the settings directly in the top procedure's code. The branch metrics make use of HAMMING DISTANCE as opposed to CLOSENESS. A version using CLOSENESS can be found on an adjacent page.

  • User mode settings allow various combinations of inputs and errors to be applied.
  • Both coders produce two bits of output for every one bit of input. The message input (display stream m) can be specified by the user, manually or generated randomly to any given length. The decoder output message is distinguished from the original as m*.
  • The user can run one cycle or many. Long cycle averaging is often useful. A message box summarizes the BER (bit error rate) results across all cycles. The user can output the metrics and basic streams for one chosen cycle to the worksheet.
  • The coder output is modified to include errors. This simulates the effect of random noise in a transmission channel. The user can set specific errors in exact positions or apply random errors throughout to a specified bit error rate. Recall that error bit positions apply to the output of the coder and that the number of bits there will be double that of the message input.
  • The display streams are labeled. The user can display the metrics and streams for a cycle. The streams are:
    • m is the original message input to the coder.
    • c is the coded output from the coder without any errors.
    • r is the received version of the coder output with the applied errors.
    • m* is the decoder output, the recovered message.

The VBA Code[edit | edit source]

The code is provided below in one complete module. Copy the code into a standard module. Set options in the top procedure RunCoding, then run that procedure to obtain a summary of error correcting results. The process will clear Sheet1, so be sure that no other essential work is located there. As an example of setting the options, assume that the intention is to test the performance of the 7,5 configuration with both random inputs and random errors to BER 0.01. Proceed as follows:

  • Set nCodePolyGen= 75 to select the 111,101 configuration,
  • nModeNumber = 8 for random inputs with random errors,
  • nAutoCycles = 100 for the average of 100 blocks,
  • nLenAutoInput = 500 to use five hundred bits in each input block,
  • nNumCdrFlushBits = 3 to add flushing bits at end of each input block,
  • sngBER = 0.01 to apply one percent errors,
  • Other options can be ignored for this task.
  • Run the procedure RunCoding. Output for the first cycle will be displayed on sheet one, and a summary for the changed BER across the decoder will appear on a message box when the run is complete. Re-save the code or press the editor's reset button between runs with new parameters.

The Module[edit | edit source]

Modification 14/Aug/18; removed column numbers restriction. User responsibility now.
Code Functional 11/Aug/18.
Modification 11/Aug/18; corrected accumulated errors and procedure ColourTheErrors().
Modification 10/Jan/18; corrected error in name of procedure to run.
Modification 03/Nov/17; added back path edge values stream to sheet display.
Modification 01/Nov/17; corrected errors in coding.
Modification 31/Oct/17; added back path coloring.

Option Explicit

Sub RunCoding() ' FOR HAMMING DISTANCE METHODS
    ' Run this procedure with chosen in-code settings to study the cross-decoder performance.
    ' THIS VERSION RUNS AND OUTPUTS METRICS BASED ON HAMMING DISTANCE AS OPPOSED TO CLOSENESS
    ' Runs a Viterbi convolutional coder-decoder simulation for two rate 1/2 algorithms.
    ' Coder 7,6: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(110), Dfree=4.
    ' Coder 7,5: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(101), Dfree=5.
    ' Decoders; Viterbi to match each coder.
    ' Message inputs can be specified exactly, or randomly with chosen length.
    ' Error insertion can be exact, or random to a specified BER. Various error pair options exist.
    ' User set number of cycles and output choice. Message box for an all-cycle summary.
Notes:
    ' The 7,5 coding algorithm with the higher "free distance" = 5 is better than 7,6's with FD = 4.
    ' Configuration (7,6) handles single bit errors with error free gaps of at least six bits.
    ' Configuration (7,6) handles some errored pairs in a limited way for some input conditions.
    ' Configuration (7,5) handles single bit errors with error free gaps of at least five bits.
    ' Configuration (7,5) handles errored pairs also, with error free gaps of about 12 -15 bits between such pairs.
    ' Performance Compared: Random Inputs with Random Errors: For 1Mb total input:
    ' (7,6): BER 1E-3 in, 4E-6 out: BER 1E-2 in, 6E-4 out.
    ' (7,5): BER 1E-3 in, 1E-6 out: BER 1E-2 in, 3E-5 out.
    
Assignments:
    Dim oSht As Worksheet, vArr As Variant, vEM As Variant, bLucky As Boolean
    Dim sngBerDecIn As Single, sngBER As Single, sngBerMOut As Single, nModeNumber As Integer
    Dim LB1 As Long, UB1 As Long, x As Long, nClearErrGap As Long, nNumCdrFlushBits As Long
    Dim m As Long, nLenAutoInput As Long, nAutoCycles As Long, rd As Long, cd As Long
    Dim r As Long, nLenStream As Long, nMErr As Long, nTotMErr As Long, nTotDIErr As Long
    Dim nTotLenStream As Long, nDErr As Long, nLenIntoDec As Long, nCycleToDisplay As Long
    Dim nTotMBSent As Long, nTotEBMess As Long, nNumDEPC As Long, nFirst As Long, nCodePolyGen As Integer
    Dim sDecodedMessage As String, sDM As String, sChannelRx As String, sChannelTx As String, sEdges As String
    Dim sCodedMessage As String, sMessage As String, sMW As String, sFctr As String, vT As Variant
    
    On Error GoTo ErrorHandler
    
UserSettings:
    
    ' Set sheet 1 for output as text
    ' worksheet will be cleared and overwritten between runs
    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    ' format sheet cells
    With oSht.Columns
        .NumberFormat = "@"
        .Font.Size = 16
    End With
    oSht.Cells(1, 1).Select
    
    ' ================================================================================================================
    ' ===========================MODE NUMBER DESCRIPTIONS=============================================================
    
    ' MODE 1
    ' manual coder input- type string into variable sMessage
    ' manual decoder input errors-typed into array variable list vEM
    
    ' MODE 2
    ' manual coder input- type string into variable sMessage
    ' regular spacing of errors throughout, set gap between two errors
    ' in nClearErrGap and start position for first in nFirst
    
    ' MODE 3
    ' manual coder input- type string into variable sMessage
    ' one pair of errors only, gap between two errors is random and start
    ' position for first is set with nFirst- adjusts to input length
    
    ' MODE 4
    ' manual coder input- type string into variable sMessage
    ' auto decoder input errors- random errors with BER (bit error rate)
    ' set in sngBER
    
    ' MODE 5
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' manual decoder input errors-typed into array variable list vEM
    
    ' MODE 6
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' regular spacing of errors throughout, set gap between two errors in
    ' nClearErrGap and start position for first in nFirst
    
    ' MODE 7
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' one pair of errors only, gap between two errors is random and start
    ' position for first is set with nFirst- adjusts to input length
    
    ' MODE 8
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' auto decoder input errors- random errors with BER (bit error rate)
    ' set in sngBER
    
    ' MODE 9
    ' manual coder input- type string into variable sMessage
    ' no errors at all - no need to touch error settings
    ' -goes round error insertion
    
    ' MODE 10
    ' auto coder input- random input- length set in variable nLenAutoInput
    ' no errors at all - no need to touch error settings
    ' -goes round error insertion
    
    ' ================================================================================================================
    ' ===========================SET WORKING MODE HERE================================================================
    nCodePolyGen = 76                ' options are 76 for (2,1,3)(111,110) or 75 for (2,1,3)(111,101)
    nModeNumber = 1                  ' see meanings above
    
    ' ================================================================================================================
    ' ===========================COMMON PARAMETERS====================================================================
    
    nAutoCycles = 1               ' set the number of cycles to run
    nCycleToDisplay = nAutoCycles    ' choose the cycle number for the metrics sheet output
    
    ' ================================================================================================================
    ' ===========================RANDOM INPUT BLOCK LENGTH============================================================
    
    ' USER SET BIT LENGTH FOR INPUT TO CODER - THE MESSAGE INPUT
    nLenAutoInput = 20                ' there will be double this number at decoder input
    
    ' ================================================================================================================
    ' ===========================MANUAL INPUT SETTINGS================================================================
    
    sMessage = "10110" ' for the Wiki page example
    ' sMessage = "10110101001" ' for the Wiki page example
    ' sMessage = "10000"               ' gives impulse response 11  10  11 ...00  00  00 for 7,5
    ' sMessage = "10000"               ' gives impulse response 11  11  10 ...00  00  00 for 7,6
    ' =================================================================================================================
    ' ===========================SET BER, POSITIONS AND GAPS===========================================================
    
    nClearErrGap = 6      ' modes 2,3,7,and 6 to set an error gap
    nNumCdrFlushBits = 2  ' modes 2,3,4,6,7,and 8 to apply message end flushing
    sngBER = 0.1         ' modes 4 and 8 to insert specified bit error rate at decoder input
    nFirst = 7            ' modes 2,3,6,and 7 to set the first error position at decoder input
    
    ' =================================================================================================================
    ' ===========================MANUALLY SET ERROR PARAMETERS=========================================================
    
    ' MANUALLY SET ERROR POSITIONS - arrange list in increasing order. Applies at decoder input
    ' vEM = Array(21, 28, 35, 42, 49, 56, 62)     'for (7,6). Single errors with gaps of 6 error free bits
    ' vEM = Array(21, 27, 33, 39, 45, 52, 59)     'for (7,5). Single errors with gaps of 5 error free bits
    ' vEM = Array(21, 22, 36, 37, 52, 53, 68, 69) 'for (7,5). 4 double errors with gaps around 12 error free bits
    ' vEM = Array(20, 21)
    vEM = Array(3,9)
    
    ' =================================================================================================================
    ' =================================================================================================================
WORKING:
    
    ' CYCLE COUNT DISPLAY SPECIFIC OVERRIDES
    Select Case nModeNumber
    Case 1, 2, 9
        nAutoCycles = 1  ' some modes need only single cycle
        nCycleToDisplay = 1
    End Select
    
    Application.DisplayStatusBar = True
    
    ' RUN A SPECIFIED NUMBER OF CYCLES
    For r = 1 To nAutoCycles
        DoEvents    ' interrupt to handle system requests
        Application.StatusBar = (r * 100) \ nAutoCycles & " Percent complete"
        
        ' CODE the message stream
        ' Decide how input is produced for each mode
        ' and add three zeros for FLUSHING
        Select Case nModeNumber
        Case 1, 2, 3, 4, 9
            If Len(sMessage) < 2 Then MsgBox "Manual input string sMessage is too short - closing": Exit Sub
            sMW = sMessage & String(nNumCdrFlushBits, "0") ' manually typed message into an array list
        Case 5, 6, 7, 8, 10
            If nLenAutoInput < 2 Then MsgBox "Short string length specified -closing": Exit Sub
            sMW = AutoRandomInput(nLenAutoInput) & String(nNumCdrFlushBits, "0") ' auto random message
        End Select
        
        ' CODER
        ' obtain a coded message from the input
        Select Case nCodePolyGen
        Case 76
            ConvolutionalCoderT7B6 sMW, sCodedMessage
        Case 75
            ConvolutionalCoderT7B5 sMW, sCodedMessage
        Case Else
            MsgBox "Chosen algorithm not found - closing"
            Exit Sub
        End Select
        sChannelTx = sCodedMessage
        
        ' check that manual error selection will fit the stream
        ' auto errors have own checks
        Select Case nModeNumber
        Case 1, 5
            LB1 = LBound(vEM, 1): UB1 = UBound(vEM, 1)
            ' check whether positions are possible
            For x = LB1 To UB1
                If vEM(x) > (2 * Len(sMW)) Then
                    MsgBox "Manually selected bit positions don't fit the stream." & vbCrLf & _
                    "Increase input length or change the bit positions." & vbCrLf & _
                    "Closing."
                    Exit Sub
                End If
            Next x
        End Select
        
        ' ERRORS
        ' ADD ERRORS to sChannelTX to simulate channel noise
        ' Decide how errors are inserted for each mode
        Select Case nModeNumber
        Case 1, 5   ' manual error assignment
            sChannelRx = AddFixedErrs(sChannelTx, vEM)
        Case 2, 6   ' two error spacing, manual gap and start
            sChannelRx = FixedSpacedErrors(sChannelTx, nFirst, nClearErrGap, 0)
        Case 3, 7   ' two errors only, random gap and manual start
            sChannelRx = TwoErrOnlyRndGap(sChannelTx, nFirst, 0)
        Case 4, 8   ' auto random errors to manual BER setting
            sChannelRx = InsertBERRnd(sChannelTx, sngBER, 0)
        Case 9, 10  ' no errors at all
            sChannelRx = sChannelTx
        End Select
        
        ' DECODER
        ' using a Viterbi trellis algorithm
        
        Select Case nCodePolyGen
        Case 75
            ConvolutionalDecodeD sChannelRx, sDecodedMessage, sEdges, bLucky, 75, vArr, vT
        Case 76
            ConvolutionalDecodeD sChannelRx, sDecodedMessage, sEdges, bLucky, 76, vArr, vT
        Case Else
            MsgBox "Chosen algorithm not found - closing"
            Exit Sub
        End Select
        sDM = sDecodedMessage
        
        ' SELECTIVE DISPLAY FOR SHEET - display for any ONE cycle
        If Application.ScreenUpdating = True Then Application.ScreenUpdating = False
        If r = nCycleToDisplay And nCycleToDisplay <> 0 Then
            oSht.Activate
            oSht.Cells.ClearContents             'remove text
            oSht.Cells.Interior.Pattern = xlNone 'remove color fill
            ' chosen run metrics to sheet
            For rd = LBound(vArr, 2) To UBound(vArr, 2)
                For cd = LBound(vArr, 1) To UBound(vArr, 1)
                    oSht.Cells(rd, cd + 1) = CStr(vArr(cd, rd))
                Next cd
            Next rd
            With oSht ' block in unused nodes and add notes
                .Cells(1, 1) = "0"
                .Cells(2, 1) = "*"
                .Cells(3, 1) = "*"
                .Cells(4, 1) = "*"
                .Cells(2, 2) = "*"
                .Cells(4, 2) = "*"
                .Cells(12, 1) = "Notes:": .Cells(12, 2) = "Currently using (" & nCodePolyGen & ") configuration."
                .Cells(13, 1) = "m:"
                .Cells(14, 1) = "c:"
                .Cells(15, 1) = "r:"
                .Cells(16, 1) = "r*:"
                .Cells(17, 1) = "m*:"
                .Cells(13, 2) = "The original message stream:"
                .Cells(14, 2) = "The coded output stream:"
                .Cells(15, 2) = "The coded output with any channel errors in magenta:"
                .Cells(16, 2) = "The back path edge values:"
                .Cells(17, 2) = "The recovered message with any remaining errors in red:"
                .Cells(18, 2) = "The decoder back path is shown in yellow:"
            End With
            oSht.Range(Cells(13, 2), Cells(18, 2)).Font.Italic = True
            
            DigitsToSheetRow sMW, 1, 6, "m"               ' message in
            DigitsToSheetRow sChannelTx, 2, 7, "c"        ' correctly coded message
            DigitsToSheetRow sChannelRx, 2, 8, "r"        ' coded message as received
            DigitsToSheetRow sEdges, 2, 9, "r*"           ' back path edge values
            DigitsToSheetRow sDecodedMessage, 1, 10, "m*" ' message out
            
            ' tint the back path cells
            For cd = LBound(vT, 1) To UBound(vT, 1)
                ' MsgBox vT(cd, 1) & " " & vT(cd, 2)
                oSht.Cells(vT(cd, 1), vT(cd, 2) + 1).Interior.Color = RGB(249, 216, 43) ' yellow-orange
            Next cd
        End If
        
        ' IN-LOOP DATA COLLECTION
        ' ACCUMULATE DATA across all cycles
        nMErr = NumBitsDifferent(sMW, sDM, nLenStream)                ' message errors single cycle
        nDErr = NumBitsDifferent(sChannelRx, sChannelTx, nLenIntoDec) ' num decoder input errors single cycle
        nTotLenStream = nTotLenStream + nLenStream                    ' accum num message bits all cycles
        nTotMErr = nTotMErr + nMErr                                   ' accum num message error bits all cycles
        nTotDIErr = nTotDIErr + nDErr                                 ' accum num decoder input errors all cycles
        
        ' reset cycle error counters
        nDErr = 0: nDErr = 0
    Next r ' end of main cycle counter
    
Transfers:
    
    ' HIGHLIGHT ERRORS ON WORKSHEET - message bit errors red, changes to back path magenta
    ColourTheErrors Len(sMW)  ' mark input and output errors for block length and flushing 
    
    ' PREPARE ALL-CYCLE SUMMARY
    nTotMBSent = nTotLenStream                               ' accum num message bits all cycles
    nTotEBMess = nTotMErr                                    ' accum num message err bits all cycles
    nNumDEPC = nTotDIErr / nAutoCycles                       ' num input errors added decoder input each cycle
    sngBerDecIn = Round(nTotDIErr / (nTotMBSent * 2), 10)    ' channel BER decoder input all cycles
    sngBerMOut = Round(nTotEBMess / nTotMBSent, 10)          ' message BER decoder output all cycles
    If sngBerMOut = 0 Then
        sFctr = "Perfect"
    Else
        sFctr = Round(sngBerDecIn / sngBerMOut, 1)           ' BER improvement across decoder
    End If
    
    ' OUTPUT SUMMARY
    MsgBox "Total of all message bits sent   : " & nTotMBSent & vbCrLf & _
    "Total errored bits in all received messages   : " & nTotEBMess & vbCrLf & _
    "Number channel errors per cycle   : " & nNumDEPC & " in block lengths of   : " & nLenIntoDec & vbCrLf & _
    "BER applied over all decoder input   : " & sngBerDecIn & " : " & sngBerDecIn * 100 & "%" & vbCrLf & _
    "BER for all messages out of decoder   : " & sngBerMOut & " : " & sngBerMOut * 100 & "%" & vbCrLf & _
    "Improvement factor across decoder   : " & sFctr
    
    ' RESETS
    If Application.ScreenUpdating = False Then Application.ScreenUpdating = True
    Application.StatusBar = ""
    
    Exit Sub
    
ErrorHandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
        Case 13 ' early exit for certain settings mistakes
            Err.Clear
            Exit Sub
        Case Else
            MsgBox "Error number: " & Err.Number & vbNewLine & _
            "Error source: " & Err.Source & vbNewLine & _
            "Description: " & Err.Description & vbNewLine
            Err.Clear
            Exit Sub
        End Select
    End If
End Sub

Function ConvolutionalCoderT7B5(ByVal sInBitWord As String, sOut As String)
    ' rate 1/2 coder; one bit in leads to two bits out
    ' 3 register equivalent, constraint 3
    ' generator polynomials are top = (1,1,1) and bottom = (1,0,1)
    ' taken for output first top then bottom
    
    Dim x0 As Long, x1 As Long, x2 As Long
    Dim sOut7 As String, sOut5 As String
    Dim n As Long, sOutBitWord As String
    
    If sInBitWord = "" Or Len(sInBitWord) < 5 Then
        MsgBox "Longer input required for ConvolutionalCoder - closing"
        Exit Function
    End If
    
    ' itialise all registers with zeros
    x0 = 0: x1 = 0: x2 = 0
    
    ' run the single input bits through the shift register
    For n = 1 To Len(sInBitWord) ' this includes any flushing bits
        DoEvents
        ' shift in one bit
        x2 = x1                          ' second contents into third position
        x1 = x0                          ' first contents into second position
        x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first
        
        ' combine register outputs
        sOut7 = x0 Xor x1 Xor x2         ' top adder output
        sOut5 = x0 Xor x2                ' bottom adder output
        
        ' combine and accumulate two adder results
        sOutBitWord = sOutBitWord & sOut7 & sOut5
        sOut = sOutBitWord
    Next n
    
End Function

Function ConvolutionalCoderT7B6(ByVal sInBitWord As String, sOut As String)
    ' rate 1/2 coder; one bit in leads to two bits out
    ' 3 register equivalent, constraint 3
    ' generator polynomials are top = (1,1,1) and bottom = (1,1,0)
    ' taken for output first top then bottom
    
    Dim x0 As Long, x1 As Long, x2 As Long
    Dim sOut7 As String, sOut6 As String
    Dim n As Long, sOutBitWord As String
    
    If sInBitWord = "" Or Len(sInBitWord) < 5 Then
        MsgBox "Longer input required for ConvolutionalCoder - closing"
        Exit Function
    End If
    
    ' itialise all registers with zeros
    x0 = 0: x1 = 0: x2 = 0
    
    ' run the single input bits through the shift register
    For n = 1 To Len(sInBitWord) ' this includes any flushing bits
        DoEvents
        ' shift in one bit
        x2 = x1                          ' second contents into third position
        x1 = x0                          ' first contents into second position
        x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first
        
        ' combine register outputs
        sOut7 = x0 Xor x1 Xor x2         ' top adder output
        sOut6 = x0 Xor x1                ' bottom adder output
        
        ' combine and accumulate two adder results
        sOutBitWord = sOutBitWord & sOut7 & sOut6
        sOut = sOutBitWord
    Next n
    
End Function

Function FixedSpacedErrors(ByVal sIn As String, ByVal nStart As Long, ByVal nErrFreeSpace As Long, _
    nTail As Long, Optional nErrCount As Long) As String
    
    ' returns parameter input string in function name with errors added
    ' at fixed intervals, set by nERRFreeSpace, the error free space between errors,
    ' and sequence starts with positon nStart.   Total number of errors placed is found in option parameter nErrCount
    ' nTail is the number of end bits to keep clear of errors.
    
    Dim n As Long, nWLen As Long, sAccum As String, c As Long, sSamp As String, nModBit As Long
    
    ' check for an empty input string
    If sIn = "" Then
        MsgBox "Empty string input in FixedSpacedErrors - closing"
        Exit Function
    End If
    
    ' get length of input less tail piece
    nWLen = Len(sIn) - nTail
    
    ' check length of input sufficient for parameters
    If nWLen - nStart < nErrFreeSpace + 1 Then
        MsgBox "Input too short in FixedSpacedErrors - increase length -closing"
        Exit Function
    End If
    
    ' accum the part before the start error
    sAccum = Mid$(sIn, 1, nStart - 1)
    
    ' modify the bit in start position and accum result
    sSamp = Mid$(sIn, nStart, 1)
    nModBit = CLng(sSamp) Xor 1
    sAccum = sAccum & CStr(nModBit)
    nErrCount = 1      ' count one error added
    
    ' insert fixed interval errors thereafter
    For n = nStart + 1 To nWLen
        sSamp = Mid$(sIn, n, 1)
        c = c + 1
        If c = nErrFreeSpace + 1 And n <= nWLen Then ' do the stuff
            c = 0
            nModBit = CLng(sSamp Xor 1)
            sAccum = sAccum & CStr(nModBit)
            nErrCount = nErrCount + 1
        Else
            sAccum = sAccum & sSamp
        End If
    Next n
    
    FixedSpacedErrors = sAccum
    
End Function

Function TwoErrOnlyRndGap(ByVal sIn As String, ByVal nStart As Long, ByVal nTail As Long) As String
    ' returns input string in function name with only 2 added errors, the first at parameter position and
    ' the second after a random gap.
    ' nTail is the number of end bits to keep clear of errors.
    
    Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long
    Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String
    
    ' find length free of tail bits
    nRange = Len(sIn) - nTail
    
    ' check that sIn is long enough
    If nRange < nStart + 1 Then
        MsgBox "sIn too short for start point in TwoErrOnlyRndGap - closing"
        Exit Function
    End If
    
    ' set number of errors needed
    nReqNumErr = 2 ' one start and one random
    
    ' dimension an array to hold the work
    ReDim vA(1 To Len(sIn), 1 To 3)
    
    ' load array col 1 with the input bits
    ' and mark the start bit for error
    For r = LBound(vA, 1) To UBound(vA, 1)
        vA(r, 1) = CLng(Mid$(sIn, r, 1))
        If r = nStart Then ' mark start bit with flag
            vA(r, 2) = 1
        End If
    Next r
    
    ' mark intended positions until right number of
    ' non-overlapping errors is clear
    Do Until nCount = nReqNumErr
        nCount = 0 ' since first err in place
        DoEvents
        ' get a sample of row numbers in the working range
        nSample = Int((nRange - (nStart + 1) + 1) * Rnd + (nStart + 1))
        ' error flag added to col 2 of intended row
        vA(nSample, 2) = 1 ' 1 denotes intention
        
        ' run through array col 1
        For c = LBound(vA, 1) To UBound(vA, 1)
            ' count all intention markers so far
            If vA(c, 2) = 1 Then
                nCount = nCount + 1
            End If
        Next c
    Loop
    
    ' when num errors is right modify the ones flagged
    For r = LBound(vA, 1) To UBound(vA, 1)
        sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2))
    Next r
    
    TwoErrOnlyRndGap = sAccum
    
End Function

Function AddFixedErrs(ByVal sIn As String, vA As Variant) As String
    ' returns string in function name with errors added in fixed positions.
    ' positions are set by one dimensional list in vA array
    
    Dim c As Long, nPosition As Long, UB1 As Long, LB1 As Long
    Dim sSamp As String, sWork As String, sSamp2 As String, sAccum As String
    
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
    
    sWork = sIn
    For nPosition = LB1 To UB1 ' 0 to 2 eg
        For c = 1 To Len(sWork)
            sSamp = Mid$(sWork, c, 1)
            If c = vA(nPosition) Then
                sSamp2 = (1 Xor CLng(sSamp))
                sAccum = sAccum & sSamp2
            Else
                sAccum = sAccum & sSamp
            End If
        Next c
        sWork = sAccum
        sAccum = ""
    Next nPosition
    
    AddFixedErrs = sWork
    
End Function

Function InsertBERRnd(ByVal sIn As String, ByVal BER As Single, ByVal nTail As Long) As String
    ' returns input string of bits with added random errors in function name
    ' number of errors depends on length of sIn and BER parameter
    ' Set nTail to zero to apply errors to flushing bits too
    
    Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long
    Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String
    
    ' find length free of nTail eg, remove flushing
    nRange = Len(sIn) - nTail
    
    ' find number of errors that are needed
    nReqNumErr = CLng(BER * nRange) ' Clng rounds fractions
    If nReqNumErr < 1 Then
        MsgBox "Requested error rate produces less than one error in InsertBERRnd" & vbCrLf & _
        "Increase stream length, or reduce BER, or both - closing"
        Exit Function
    End If
    
    ' dimension an array to hold the work
    ReDim vA(1 To Len(sIn), 1 To 3)
    
    ' load array col 1 with the input bits
    For r = LBound(vA, 1) To UBound(vA, 1)
        vA(r, 1) = CLng(Mid$(sIn, r, 1))
    Next r
    
    ' mark intended positions until right number of
    ' non-overlapping errors is clear
    Do Until nCount = nReqNumErr
        nCount = 0
        DoEvents
        ' get a sample of row numbers in the working range
        nSample = Int((nRange - 1 + 1) * Rnd + 1)
        ' error flag added to col 2 of intended row
        vA(nSample, 2) = 1 ' 1 denotes intention
        
        ' run through array col 1
        For c = LBound(vA, 1) To UBound(vA, 1)
            ' count all intention markers so far
            If vA(c, 2) = 1 Then
                nCount = nCount + 1
            End If
        Next c
    Loop
    
    ' when num errors is right modify the ones flagged
    For r = LBound(vA, 1) To UBound(vA, 1)
        sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2))
    Next r
    
    InsertBERRnd = sAccum
    
End Function

Sub ConvolutionalDecodeD(ByVal sIn As String, sOut As String, sOut2 As String, bAmbiguous As Boolean, nConfiguration As Long, vRet As Variant, vTint As Variant)
    ' works with rate 1/2 coder; one bit in leads to two bits out
    ' 3 register equivalent, constraint 3, generator polynomials are top = (1,1,1) and bottom = (1,1,0) for 7,6
    ' and (1,1,1) and (1,0,1) for 7,5, selected by parameter nConfiguration= 75 or 76.
    
    ' NOTES: All calculations of metrics and displays use Hamming distance in this version.
    '       In branch estimates the highest is always discarded.
    '       If branch metrics are equal, discard the bottom of the two incoming branches.
    '       Working for metrics assumes position at node with two incoming branches.
    '       Back track starts at last column's metric minimum then follows survivor paths
    '       back to state "a" time zero.
    
    Dim aV() As String, vH As Variant, sWIn As String, sPrevStateAccumL As String, sPrevStateAccumU As String
    Dim nStartR As Long, nStartC As Long, sEdgeBits As String, sInputBit As String
    Dim r As Long, c As Long, nSwapR As Long, nSwapC As Long
    Dim nVert As Long, nTime As Long, bUpperPath As Boolean, vW As Variant
    Dim sAccumEdgeValues As String, sAccumImpliesBits As String
    Dim sCurrState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, sLSOut As String
    Dim sBitU As String, sBitL As String, sRcdBits As String, nNumTrans As Long
    Dim sProposedAccumU As String, sProposedAccumL As String, sDiscardedU As String, sDiscardedL As String
    Dim sNodeAccum As String, nNumLows As Long
    
    ' check that number received is even
    sWIn = sIn
    If Len(sWIn) Mod 2 = 0 Then
        nNumTrans = Len(sWIn) / 2
    Else
        MsgBox "Odd bit pairing at input decoder -closing"
        Exit Sub
    End If
    
    ' dimension arrays
    Erase aV()
    ReDim aV(0 To nNumTrans, 1 To 4, 1 To 3)  ' x transitions, y states, z node data
    ReDim vH(1 To 4, 1 To 3)                  ' r states, c node data
    ReDim vW(0 To nNumTrans, 1 To 4)          ' r transitions, c states
    ReDim vTint(0 To nNumTrans, 1 To 2)       ' back path tint array
    aV(0, 1, 3) = "0"                         ' set metric for zero node
    
    ' CYCLE LOOP
    For nTime = 1 To nNumTrans
        For nVert = 1 To 4
            DoEvents
            
            ' Get incoming branch data for current node
            If nConfiguration = 75 Then
                GeneralDataT7B5 nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL
            ElseIf nConfiguration = 76 Then
                GeneralDataT7B6 nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL
            End If
            
            ' Get the received bits for the incoming transition
            sRcdBits = Mid$(sWIn, (nTime * 2) - 1, 2)
            
            ' get the current node's previous states' metrics
            If sCurrState = "a" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3)
            If sCurrState = "a" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3)
            If sCurrState = "b" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3)
            If sCurrState = "b" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3)
            If sCurrState = "c" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3)
            If sCurrState = "c" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3)
            If sCurrState = "d" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3)
            If sCurrState = "d" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3)
            
            ' NOTE ON EXCEPTIONS
            ' Exceptions for transitions 0, 1 and 2.  Some redundant, or fewer than two incoming branches.
            ' Nodes with single incoming branches; mark blind branches same edge value as existing edge,
            ' and mark their previous metrics as arbitrarily high.  Because policy for choosing equal metrics is always
            ' to discard the bottom one, exceptions can then be handled in same loop.
            ' Zero column is handled entirely by settings for transition 1.
            
            ' Apply exceptions settings
            If nConfiguration = 75 Then
                FrontExceptions75D nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
            ElseIf nConfiguration = 76 Then
                FrontExceptions76D nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
            Else
                MsgBox "Configuration not defined"
            End If
            
            ' Calculate incoming branch metrics and add their previous path metrics to each
            sProposedAccumU = CStr(GetProposedAccum(sRcdBits, sUSOut, sPrevStateAccumU))
            sProposedAccumL = CStr(GetProposedAccum(sRcdBits, sLSOut, sPrevStateAccumL))
            
            ' Decide between the two proposed metrics for the current node
            ' Accept the higher value branch metric and discard the other
            ' If same in value, choose the top branch and discard the bottom.
            If CLng(sProposedAccumU) > CLng(sProposedAccumL) Then
                sDiscardedL = "Keep": sDiscardedU = "Discard"
                sNodeAccum = sProposedAccumL
            ElseIf CLng(sProposedAccumU) < CLng(sProposedAccumL) Then
                sDiscardedL = "Discard": sDiscardedU = "Keep"
                sNodeAccum = sProposedAccumU
            ElseIf CLng(sProposedAccumU) = CLng(sProposedAccumL) Then
                sDiscardedL = "Discard": sDiscardedU = "Keep"
                sNodeAccum = sProposedAccumU
            End If
            
            ' Update the node array with the discard data
            aV(nTime, nVert, 1) = sDiscardedU  ' whether or not upper incoming discarded
            aV(nTime, nVert, 2) = sDiscardedL  ' whether or not lower incoming discarded
            
            ' Update the node array with the value of path metric for the current node
            aV(nTime, nVert, 3) = sNodeAccum   ' update work array with metric
            
            ' Update return work array with node metric value for the sheet display
            vW(nTime, nVert) = CLng(sNodeAccum) ' update return display array with metric
            
        Next nVert
    Next nTime
    
    ' Transfer last column metric values to a work array
    c = nNumTrans                      ' the last column number
    For r = 1 To 4                     ' number of rows in every column
        vH(r, 1) = CLng(aV(c, r, 3))   ' metrics
        vH(r, 2) = CLng(c)             ' column where metric found in main array
        vH(r, 3) = CLng(r)             ' row where metric found in main array
    Next r
    
    ' Sort descending
    SortMetricsArr2D1Key vH, 1, 1, 1        ' and assoc recs are in same row
    
    ' Detect start point ambiguity for possible future use
    ' Count number of entries with same low value in column
    nNumLows = 0
    For r = 1 To 4   ' number rows in every column
        If vH(1, 1) = vH(r, 1) Then nNumLows = nNumLows + 1
    Next r
    If nNumLows > 1 Then bAmbiguous = True
    
    ' Note the row and column numbers for the back path start point
    nStartR = CLng(vH(1, 3))               ' retrieve row number
    nStartC = CLng(vH(1, 2))               ' retrieve col number
    
    ' add coordinates to vTint
    vTint(nStartC, 1) = nStartR
    vTint(nStartC, 2) = nStartC
    
    ' BACK PATH
    ' Navigate the back path and extract its data
    Do Until nStartC <= 0
        DoEvents  ' allow system requests
        
        ' Find survivor path into this node
        ' if upperpath is open...
        If aV(nStartC, nStartR, 1) = "Keep" Then bUpperPath = True Else bUpperPath = False
        ' if lower path is open...
        If aV(nStartC, nStartR, 2) = "Keep" Then bUpperPath = False Else bUpperPath = True
        
        ' Get present state
        sCurrState = GetStateFmRow(nStartR) ' common
        
        ' Use present state name to fetch the output bits
        If nConfiguration = 75 Then
            GetOutputBitsT7B5 sCurrState, bUpperPath, sEdgeBits, sInputBit
        ElseIf nConfiguration = 76 Then
            GetOutputBitsT7B6 sCurrState, bUpperPath, sEdgeBits, sInputBit
        Else
            MsgBox "Configuration not defined"
        End If
        
        ' Accumulate output and input values for hop
        sAccumEdgeValues = sEdgeBits & sAccumEdgeValues    ' edge values -not used
        sAccumImpliesBits = sInputBit & sAccumImpliesBits  ' decoded message -used
        
        ' Get array coordinates for next node in back path
        If nConfiguration = 75 Then
            GetPosOfSourceT7B5 nStartR, nStartC, bUpperPath, nSwapR, nSwapC
        ElseIf nConfiguration = 76 Then
            GetPosOfSourceT7B6 nStartR, nStartC, bUpperPath, nSwapR, nSwapC
        Else
            MsgBox "Configuration not defined"
        End If
        
        ' Update the new position coordinates for the next hop
        nStartR = nSwapR
        nStartC = nSwapC
        
        ' add coordinates to vTint
        vTint(nStartC, 1) = nStartR
        vTint(nStartC, 2) = nStartC
        
    Loop
    
Transfers:
    
    ReDim vRet(LBound(vW, 1) To UBound(vW, 1), LBound(vW, 2) To UBound(vW, 2))
    vRet = vW
    sOut = sAccumImpliesBits 'message single bit stream
    sOut2 = sAccumEdgeValues 'back path edge double bit stream
    
End Sub

Function FrontExceptions75D(ByVal nT As Long, ByVal nV As Long, _
    sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean
    ' applies the exceptions for configuration 7,5 - applies to distance only
    
    If nT = 1 And nV = 1 Then
        sLSO = "00": sUSO = "00": sPSAL = "20": sPSAU = "0"
    ElseIf nT = 1 And nV = 3 Then
        sLSO = "11": sUSO = "11": sPSAL = "20": sPSAU = "0"
    ElseIf nT = 2 And nV = 1 Then
        sLSO = "00": sUSO = "00": sPSAL = "20"
    ElseIf nT = 2 And nV = 2 Then
        sLSO = "10": sUSO = "10": sPSAL = "20"
    ElseIf nT = 2 And nV = 3 Then
        sLSO = "11": sUSO = "11": sPSAL = "20"
    ElseIf nT = 2 And nV = 4 Then
        sLSO = "01": sUSO = "01": sPSAL = "20"
    End If
    
    FrontExceptions75D = True
    
End Function

Function FrontExceptions76D(ByVal nT As Long, ByVal nV As Long, _
    sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean
    ' applies the exceptions for configuration 7,5 -applies to distance only
    
    If nT = 1 And nV = 1 Then
        sLSO = "00": sUSO = "00": sPSAL = "20": sPSAU = "0"
    ElseIf nT = 1 And nV = 3 Then
        sLSO = "11": sUSO = "11": sPSAL = "20": sPSAU = "0"
    ElseIf nT = 2 And nV = 1 Then
        sLSO = "00": sUSO = "00": sPSAL = "20" ' arbitrarily high
    ElseIf nT = 2 And nV = 2 Then
        sLSO = "11": sUSO = "11": sPSAL = "20"
    ElseIf nT = 2 And nV = 3 Then
        sLSO = "11": sUSO = "11": sPSAL = "20"
    ElseIf nT = 2 And nV = 4 Then
        sLSO = "00": sUSO = "00": sPSAL = "20"
    End If
    
    FrontExceptions76D = True
    
End Function

Function SortMetricsArr2D1Key(ByRef vA As Variant, _
    Optional ByVal bIsAscending As Boolean = True, _
    Optional ByVal bIsRowSort As Boolean = True, _
    Optional ByVal SortIndex As Long = -1, _
    Optional ByRef vRet As Variant) As Boolean
    ' --------------------------------------------------------------------------------
    ' Procedure : Sort2DArr
    ' Purpose   : Bubblesorts a 2D array on 1 key, up or down, on any column or row.
    '             Options include in-place, with the source changed, or
    '             returned in vRet, with the source array intact.
    '             Optional parameters default to: ROW SORT in place, ASCENDING,
    '             using COLUMN ONE as the key.
    ' --------------------------------------------------------------------------------
    
    Dim condition1 As Boolean, vR As Variant
    Dim i As Long, j As Long, y As Long, t As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim bWasMissing As Boolean
    
    ' find bounds of vA data input array
    loR = LBound(vA, 1): hiR = UBound(vA, 1)
    loC = LBound(vA, 2): hiC = UBound(vA, 2)
    
    ' find whether optional vR was initially missing
    bWasMissing = IsMissing(vRet)
    ' If Not bWasMissing Then Set vRet = Nothing
    
    ' check input range of SortIndex
    If bIsRowSort And (SortIndex < loC Or SortIndex > hiC) Then
        MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
        Exit Function
    Else:
    End If
    
    If Not bIsRowSort And (SortIndex < loR Or SortIndex > hiR) Then
        MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
        Exit Function
    Else:
    End If
    
    ' pass to a work variable
    vR = vA
    
    ' steer input options
    If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
    
ROWSORT:
    For i = loR To hiR - 1
        For j = loR To hiR - 1
            If bIsAscending Then
                condition1 = vR(j, SortIndex) > vR(j + 1, SortIndex)
            Else
                condition1 = vR(j, SortIndex) < vR(j + 1, SortIndex)
            End If
            If condition1 Then
                For y = loC To hiC
                    t = vR(j, y)
                    vR(j, y) = vR(j + 1, y)
                    vR(j + 1, y) = t
                Next y
            End If
        Next
    Next
    GoTo Transfers
    
COLSORT:
    For i = loC To hiC - 1
        For j = loC To hiC - 1
            If bIsAscending Then
                condition1 = vR(SortIndex, j) > vR(SortIndex, j + 1)
            Else
                condition1 = vR(SortIndex, j) < vR(SortIndex, j + 1)
            End If
            If condition1 Then
                For y = loR To hiR
                    t = vR(y, j)
                    vR(y, j) = vR(y, j + 1)
                    vR(y, j + 1) = t
                Next y
            End If
        Next
    Next
    GoTo Transfers
    
Transfers:
    ' decide whether to return in vA or vRet
    If Not bWasMissing Then
        ' vRet was the intended return array
        ' so return vRet leaving vA intact
        vRet = vR
    Else:
        ' vRet is not intended return array
        ' so reload vA with vR
        vA = vR
    End If
    
    ' set return function value
    SortMetricsArr2D1Key = True
    
End Function

Function GeneralDataT7B5(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _
    sLSOut As String, sBitU As String, sBitL As String) As Boolean
    ' takes as input nVert as position in trellis column and returns various data for that state
    
    Select Case nVert
    Case 1
        sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "11": sBitU = "0": sBitL = "0"
    Case 2
        sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "10": sLSOut = "01": sBitU = "0": sBitL = "0"
    Case 3
        sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "00": sBitU = "1": sBitL = "1"
    Case 4
        sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "01": sLSOut = "10": sBitU = "1": sBitL = "1"
    Case Else
    End Select
    
    GeneralDataT7B5 = True
    
End Function

Function GeneralDataT7B6(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _
    sLSOut As String, sBitU As String, sBitL As String) As Boolean
    ' takes as input nVert as position in trellis column and returns various data for that state
    
    Select Case nVert
    Case 1
        sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "10": sBitU = "0": sBitL = "0"
    Case 2
        sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "11": sLSOut = "01": sBitU = "0": sBitL = "0"
    Case 3
        sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "01": sBitU = "1": sBitL = "1"
    Case 4
        sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "00": sLSOut = "10": sBitU = "1": sBitL = "1"
    Case Else
    End Select
    
    GeneralDataT7B6 = True
    
End Function

Function GetStateFmRow(nRow As Long) As String
    ' returns alpha name of state for parameter
    ' row position in trellis column
    
    Select Case nRow
    Case 1
        GetStateFmRow = "a"
    Case 2
        GetStateFmRow = "b"
    Case 3
        GetStateFmRow = "c"
    Case 4
        GetStateFmRow = "d"
    End Select
    
End Function

Function GetOutputBitsT7B6(sState As String, bUpper As Boolean, _
    sEdgeBits As String, sInputBit As String) As Boolean
    ' returns edge value and input given the alpha state name
    ' and choice of top or bottom branch.
    ' Applies to incoming branches joining at the node.
    
    Select Case sState
    Case "a"
        If bUpper = True Then
            sEdgeBits = "00"
            sInputBit = "0"
        Else
            sEdgeBits = "10"
            sInputBit = "0"
        End If
    Case "b"
        If bUpper = True Then
            sEdgeBits = "11"
            sInputBit = "0"
        Else
            sEdgeBits = "01"
            sInputBit = "0"
        End If
    Case "c"
        If bUpper = True Then
            sEdgeBits = "11"
            sInputBit = "1"
        Else
            sEdgeBits = "01"
            sInputBit = "1"
        End If
    Case "d"
        If bUpper = True Then
            sEdgeBits = "00"
            sInputBit = "1"
        Else
            sEdgeBits = "10"
            sInputBit = "1"
        End If
    End Select
    
    GetOutputBitsT7B6 = True
    
End Function

Function GetOutputBitsT7B5(sState As String, bUpper As Boolean, _
    sEdgeBits As String, sInputBit As String) As Boolean
    ' returns edge value and input given the alpha state name
    ' and choice of top or bottom branch.
    ' Applies to incoming branches joining at the node.
    
    Select Case sState
    Case "a"
        If bUpper = True Then
            sEdgeBits = "00"
            sInputBit = "0"
        Else
            sEdgeBits = "11"
            sInputBit = "0"
        End If
    Case "b"
        If bUpper = True Then
            sEdgeBits = "10"
            sInputBit = "0"
        Else
            sEdgeBits = "01"
            sInputBit = "0"
        End If
    Case "c"
        If bUpper = True Then
            sEdgeBits = "11"
            sInputBit = "1"
        Else
            sEdgeBits = "00"
            sInputBit = "1"
        End If
    Case "d"
        If bUpper = True Then
            sEdgeBits = "01"
            sInputBit = "1"
        Else
            sEdgeBits = "10"
            sInputBit = "1"
        End If
    End Select
    
    GetOutputBitsT7B5 = True
    
End Function

Function GetPosOfSourceT7B5(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _
    nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean
    ' returns the array column and row for an incoming branch,
    ' given its position in trellis column and choice of top or bottom branch.
    
    Dim sNodesState As String
    
    ' convert to string state names
    Select Case nNodeR
    Case 1
        sNodesState = "a"
    Case 2
        sNodesState = "b"
    Case 3
        sNodesState = "c"
    Case 4
        sNodesState = "d"
    End Select
    
    ' for c=0 only
    If nNodeC = 0 Then
        MsgBox "No source beyond zero column"
        Exit Function
    End If
    
    ' For c>0 only
    Select Case sNodesState
    Case "a"
        If bUpper = True Then
            nEdgeSourceR = 1
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 2
            nEdgeSourceC = nNodeC - 1
        End If
    Case "b"
        If bUpper = True Then
            nEdgeSourceR = 3
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 4
            nEdgeSourceC = nNodeC - 1
        End If
    Case "c"
        If bUpper = True Then
            nEdgeSourceR = 1
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 2
            nEdgeSourceC = nNodeC - 1
        End If
    Case "d"
        If bUpper = True Then
            nEdgeSourceR = 3
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 4
            nEdgeSourceC = nNodeC - 1
        End If
    End Select
    
    GetPosOfSourceT7B5 = True
    
End Function

Function GetPosOfSourceT7B6(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _
    nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean
    ' returns the array column and row for an incoming branch,
    ' given its position in trellis column and choice of top or bottom branch.
    
    Dim sNodesState As String
    
    ' convert to string state names
    Select Case nNodeR
    Case 1
        sNodesState = "a"
    Case 2
        sNodesState = "b"
    Case 3
        sNodesState = "c"
    Case 4
        sNodesState = "d"
    End Select
    
    ' for c=0 only
    If nNodeC = 0 Then
        MsgBox "No source beyond zero column"
        Exit Function
    End If
    
    ' For c>0 only
    Select Case sNodesState
    Case "a"
        If bUpper = True Then
            nEdgeSourceR = 1
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 2
            nEdgeSourceC = nNodeC - 1
        End If
    Case "b"
        If bUpper = True Then
            nEdgeSourceR = 3
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 4
            nEdgeSourceC = nNodeC - 1
        End If
    Case "c"
        If bUpper = True Then
            nEdgeSourceR = 1
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 2
            nEdgeSourceC = nNodeC - 1
        End If
    Case "d"
        If bUpper = True Then
            nEdgeSourceR = 3
            nEdgeSourceC = nNodeC - 1
        Else
            nEdgeSourceR = 4
            nEdgeSourceC = nNodeC - 1
        End If
    End Select
    
    GetPosOfSourceT7B6 = True
    
End Function

Function DigitsToSheetRow(ByVal sIn As String, ByVal nNumGrp As Long, _
    ByVal nRow As Long, Optional ByVal sRLabel As String = "*")
    ' takes string of digits and an option code and distributes bits to worksheet rows
    
    Dim n As Long, c As Long, sSamp As String
    Dim oSht As Worksheet
    
    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    oSht.Activate
    
    If Len(sIn) Mod nNumGrp <> 0 Then
        MsgBox "Missing bits for grouping in  DigitsToSheetRow - closing"
        Exit Function
    End If
    
    c = 0
    ' 101 010 101 010
    For n = 1 To (Len(sIn) - nNumGrp + 1) Step nNumGrp
        DoEvents
        sSamp = Mid$(sIn, n, nNumGrp)
        c = c + 1
        oSht.Cells(nRow, c + 1) = sSamp
        If c >= 16384 Then Exit For
    Next n
    oSht.Cells(nRow, 1) = sRLabel
    
End Function

Sub ColourTheErrors(ByVal nLen As Long)
    ' colors specific data to show errors
    ' changes to decoder pairs in magenta
    ' changes between input and output message in red
    ' marks individual received bit errors in bold yellow
    ' marking is limited to 256 columns to accommodate Excel 2003

    Dim oSht As Worksheet, c As Long, nRow As Long

    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    oSht.Activate
    With oSht.Cells
       .Font.Color = RGB(0, 0, 0)
       .Font.Bold = False
    End With

    'clear colours in rows below first four to preserve backpath
    For nRow = 5 To 20
       oSht.Rows(nRow).Cells.Interior.Pattern = xlNone
    Next nRow

    For c = 2 To nLen + 1 'this is specified length of the string for display
        'Note that Excel versions have different max columns
        'Up to user to get it right eg: max 256 for Excel 2003
        'block with error colouring
        'message errors are in red
        If oSht.Cells(10, c) <> oSht.Cells(6, c) Then oSht.Cells(10, c).Interior.Color = vbRed
        'received channel errors magenta
        If oSht.Cells(7, c) <> oSht.Cells(8, c) Then oSht.Cells(8, c).Interior.Color = vbMagenta

        'individual errored character colouring in yellow within magenta block
        If Left(oSht.Cells(8, c).Value, 1) <> Left(oSht.Cells(7, c).Value, 1) Then
           With oSht.Cells(8, c).Characters(1, 1).Font
              .Color = -16711681
              .Bold = True
           End With
        End If

        If Right(oSht.Cells(8, c).Value, 1) <> Right(oSht.Cells(7, c).Value, 1) Then
          With oSht.Cells(8, c).Characters(2, 1).Font
             .Color = -16711681
             .Bold = True
          End With
        End If
    Next c

End Sub
Function AutoRandomInput(ByVal nLength As Long) As String
    ' makes a pseudo random string of parameter nLength
    
    Dim n As Long, sSamp As String, sAccum As String
    
    ' Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
    
    Randomize Timer
    For n = 1 To (nLength)
        sSamp = CStr(Int((1 - 0 + 1) * Rnd + 0))
        sAccum = sAccum & sSamp
    Next n
    
    AutoRandomInput = sAccum
    
End Function

Function GetProposedAccum(ByVal sIn1 As String, ByVal sIn2 As String, ByVal sPrevAccum As String) As Long
    ' Compares two binary strings of equal length
    ' Returns the count of the bits in function name plus sPrevAccum that are different
    ' It is the Hamming distance between the two binary bit strings plus some accum metric
    
    Dim nErr As Long, n As Long, m As Long
    
    ' check that streams are same length for comparison
    If Len(sIn1) <> Len(sIn2) Then
        MsgBox "Stream lengths do not match in StrDifference - closing"
        Exit Function
    End If
    
    ' 0 and  0 =   0
    ' 0 and  1 =   1
    ' 1 and  0 =   1
    ' 1 and  1 =   0
    
    For n = 1 To Len(sIn1)
        nErr = Abs(CLng(Mid$(sIn1, n, 1)) - CLng(Mid$(sIn2, n, 1)))
        m = m + nErr
    Next n
    
Transfers:
    If sPrevAccum = "" Then sPrevAccum = "0"
    GetProposedAccum = m + CLng(sPrevAccum)
    
End Function

Function NumBitsDifferent(ByVal sIn1 As String, ByVal sIn2 As String, Optional nLength As Long) As Long
    ' compares two binary strings of equal length
    ' and returns the count of the bits in function name that are different
    ' It is the Hamming distance between the two binary bit strings
    
    Dim nErr As Long, n As Long, m As Long
    
    ' check that streams are same length for comparison
    If Len(sIn1) <> Len(sIn2) Then
        MsgBox "Stream lengths do not match in StrDifference - closing"
        Exit Function
    End If
    
    ' 0 and  0 =   0
    ' 0 and  1 =   1
    ' 1 and  0 =   1
    ' 1 and  1 =   0
    
    For n = 1 To Len(sIn1)
        nErr = Abs(CLng(Mid$(sIn1, n, 1)) - CLng(Mid$(sIn2, n, 1)))
        m = m + nErr
    Next n
    
Transfers:
    nLength = Len(sIn1)
    NumBitsDifferent = m
    
End Function

See Also[edit | edit source]

External Links[edit | edit source]


Generate Random Dictionary Words

Summary[edit | edit source]

This VBA code module works only in MS Word. It generates a pseudo random list of dictionary words, listing them in the immediate window of the VBA editor.

The VBA Code[edit | edit source]

  • Copy the code listing into a standard VBA module in MS Word and save the file as a docm type. Set the user options in the top section and run the procedure to produce the list.
  • The variable Num sets the number of words as output, and the variable TypoLen should be set to the approximate length of the sought-after words.
  • There is no ready-made collection of English words called a Dictionary in MS Word; the term is used for sets of user-constructed word lists. To access a list of English words, an indirect method needs to be used. A random word is first generated equal in length to TypoLen. The spell checker then fails to recognize the word so generates suggestions, this time as a proper collection. Provided that there is at least one such suggestion in the spell check collection, a random choice is made from among them for the output list. The loop continues until the chosen number of words has been produced.

The Code Module[edit | edit source]

Sub GetNRandomWords()
    'Prints N randomly selected words
    'in the Immediate Window
    'Works in MS WORD only
    
    Dim Sugg As SpellingSuggestions
    Dim TypoLen As Long, n As Long
    Dim sMakeWord As String, nR As Long
    Dim Num As Long, p As Long
    
    'set user options
    TypoLen = 7 'trial text length
    Num = 10    'number of samples
    
    Randomize
    Do
        p = p + 1
        Do
            DoEvents
            sMakeWord = ""
            'make a misspelled word of length TypoLen
            For n = 1 To TypoLen
                'concatenate random charas
                sMakeWord = sMakeWord & Chr(Int(26 * Rnd + Asc("a")))
            Next n
            
            'get resulting spelling suggestions collection
            Set Sugg = GetSpellingSuggestions(sMakeWord)
            
            'random select a suggestion
            If Sugg.Count >= 1 Then 'assuming there is at least one
                'random select one suggestion
                nR = Int((Sugg.Count - 1 + 1) * Rnd + 1)
                Debug.Print Sugg(nR) 'OUTPUT
                'MsgBox Sugg(nR)
            End If
        Loop Until Sugg.Count >= 1
    Loop Until p >= Num

End Sub

See Also[edit | edit source]

External Links[edit | edit source]


Transfer Data to the Worksheet

Summary[edit | edit source]

This page gives an overview of transferring data from VBA to the worksheet. The code module includes procedures for transfer of both one and two dimensional arrays to the sheet. Brief code line notes are also included for single line and block transfers.

Contents of the Module[edit | edit source]

  • The module works best if kept intact. The top procedure has code lines to run the other procedures. Just de-comment the code that you intend to run, and add comment marks to the lines that are not intended to run.
  • The code procedures include normal or transposed transfers from two dimensional arrays.
  • In addition, the handling of one dimensional arrays has been included. They can be transferred into a column or a row.
  • The placement position can be specified in every case.
  • Note that the selected worksheet will be cleared on each run, so select a worksheet for output that will not remove essential data.
  • ConvColAlphaToNum() and ConvColNumToAlpha() are included to convert worksheet column references between the alpha and numeric formats.
  • Additional procedures have been added for clearing and formatting text and the sheet.

The Code Module[edit | edit source]

Option Explicit

Sub TestArraysToSheet()
    'test proc for transfers to the sheet
    'de-comment lines to test the code
    
    Dim vDim1 As Variant, vDim2 As Variant, vTemp As Variant, vR
    Dim oSht As Worksheet, r As Long, c As Long, rTarget As Range
    Dim Rng as range
    
    ' set choice of worksheet
    Set oSht = ActiveWorkbook.Worksheets("Sheet2")
    set rng=osht.cells(1,1)
    
    ' clear existing contents of worksheet
    oSht.Activate
    oSht.Cells.ClearContents
    
    ' load 1D test array
    vDim1 = Array(9, 8, 7, 5, 6, 4, 3, 2, 1, 0) 'or,
    'vDim1 = Array("Horses", "Dogs", "Zebras", "Fleas") 'or,
    'vDim1 = Split("A B C D E F G H I J K L M N O P Q R S T U V W X Y Z", " ") 'zero based
    
    ' load 2D test array
    ReDim vDim2(1 To 20, 1 To 10)
    For r = 1 To 20
      For c = 1 To 10
         vDim2(r, c) = (r * c)
      Next c
    Next r
    
    ' CLEARING THE SHEET
    '-------------------
    oSht.Cells.ClearContents   ' clears sheet text entries only
    'oSht.Cells.ClearFormats    ' clears sheet formats only
    'oSht.Cells.Clear           ' clears everthing on sheet
    'oSht.Range("A1:G37").ClearContents   'clears entries from cell block
    'oSht.Range(oSht.Cells(1, 1), oSht.Cells(1, 9)).ClearContents 'clears entries from cell block
    'ClearRange rng, "contents"                                   'clears cell range according to option 
    'ClearWorksheet("Sheet2", 1 )                                 'clears all sheet2 cell contents only       
    
    ' REMOVE ALL WORKBOOK CHARTS
    '---------------------------
    'DeleteAllWorkbookCharts    'clears all charts from the workbook - not just those on top sheet
    
   '' TRANSFER SINGLE VALUES TO SHEET
    '--------------------------------
    'oSht.Cells(3, 7).Value = "Totals"         'string to one specified cell
    'oSht.Range("A1").Value = "Totals"         'string to one specified cell
    
    
    ' TRANSFER ONE VALUE TO A SHEET BLOCK
    '------------------------------------
    'oSht.Range(oSht.Cells(1, 1), oSht.Cells(10, 7)).Value = "N/A"
    'oSht.Range("A1:F10").Value = "N/A"
    
    
    'TRANSFER 1 DIMENSION LIST ARRAYS TO WORKSHEET
    '---------------------------------------------
    Array1DToSheetRow vDim1, "Sheet2", 3, 7    ' 1D array to sheet row, start position (3,7)
    
    'Array1DToSheetCol vDim1, "Sheet2", 3, 7    ' 1D array to sheet column, start position (3,7)
            
    
    'TRANSFER 2 DIMENSIONAL ARRAYS TO WORKSHEET
    '------------------------------------------
    'Array2DToSheet vDim2, "Sheet2", 2, 2       ' 2D array to sheet, start position (2,2)
    
    'Arr1Dor2DtoWorksheet vDim2,"Sheet2",4,5     ' 1D or 2D array to worksheet; 2D here. 
    
    'TransArray2DToSheet vDim2, "Sheet2", 2, 2  ' TRANSPOSED 2D array to sheet, start position (2,2)
    
    'TransposeArray2D vDim2, vTemp              ' alternative method of TRANSPOSED 2D array to sheet
    'Array2DToSheet vTemp,"Sheet2" , 1, 1

    'FORMAT WORKSHEET CELLS AFTER TRANSFER
    '------------------------------------------
    'FormatCells "Sheet2"                      'applies one of several formats to all cells of the worksheet  
    'FormatRange Rng, "bold"                   'applies one of several formats to the specified cell range
    
End Sub

Sub Array1DToSheetCol(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of single dimension list array to specified position in worksheet
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nElem As Long
    Dim nNewC As Long, nNewR As Long
    
    ' get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    ' get the pre-shift end points
    nElem = UBound(vIn, 1) - LBound(vIn, 1) + 1
           
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nStartRow + nElem - 1, nStartCol))
    
    'transfer the array contents to the sheet range
    rTarget.Value = Application.WorksheetFunction.Transpose(vIn)

End Sub

Sub Array1DToSheetRow(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of single dimension list array into a worksheet column
    ' The cell for the first element is set by nStartRow and nStartCol
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nElem As Long
    Dim nNewC As Long, nNewR As Long
    
    ' get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    ' get the pre-shift end points
    nElem = UBound(vIn, 1) - LBound(vIn, 1) + 1
           
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nStartRow, nStartCol + nElem - 1))
    
    'transfer the array contents to the sheet range
    rTarget.Value = vIn

End Sub

Sub TransArray2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of input 2D array to specified worksheet positions TRANSPOSED
    ' The cell for the first element is set by nStartRow and nStartCol
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nRows As Long, nCols As Long
    Dim nNewEndC As Long, nNewEndR As Long
    
    'get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    'get the pre-shift end points
    nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
    nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
    
    'swap cols and rows
    nNewEndR = nCols + nStartRow - 1
    nNewEndC = nRows + nStartCol - 1
       
    ' define the transposed range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
    
    'transfer the array contents to the sheet range
    rTarget.Value = Application.WorksheetFunction.Transpose(vIn)

End Sub

Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of input 2D array to specified worksheet positions
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nRows As Long, nCols As Long
    Dim nNewEndC As Long, nNewEndR As Long
    
    'get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    'get the pre-shift end points
    nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
    nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
    
    'modify end point for parameter starting values
    nNewEndR = nRows + nStartRow - 1
    nNewEndC = nCols + nStartCol - 1
       
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
    
    'transfer the array contents to the sheet range
    rTarget.Value = vIn

End Sub

Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _
                         ByVal nRow As Long, ByVal nCol As Long) As Boolean
    
    'Transfers a one or two dimensioned input array vA to the worksheet,
    'with top-left element at cell position nRow,nCol. sSht is the worksheet name.
    'Default 2D array transfers are made unchanged and a 1D array is displayed in a row.
            
    Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean
    Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long
    Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant
    
    'CHECK THE INPUT ARRAY
    On Error Resume Next
        'is it an array
        If IsArray(vA) = False Then
            bProb = True
        End If
        'check if allocated
        nR = UBound(vA, 1)
        If Err.Number <> 0 Then
            bProb = True
        End If
    Err.Clear
        
    If bProb = False Then
        'count dimensions
        On Error Resume Next
        Do
            nD = nD + 1
            nR = UBound(vA, nD)
        Loop Until Err.Number <> 0
    Else
        MsgBox "Parameter is not an array" & _
        vbCrLf & "or is unallocated - closing."
        Exit Function
    End If
    'get number of dimensions
    Err.Clear
    nDim = nD - 1: 'MsgBox nDim

    'get ref to worksheet
    Set oSht = ThisWorkbook.Worksheets(sSht)
       
    'set a worksheet range for array
    Select Case nDim
    Case 1 'one dimensional array
        LBR = LBound(vA): UBR = UBound(vA)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR))
    Case 2 'two dimensional array
        LBR = LBound(vA, 1): UBR = UBound(vA, 1)
        LBC = LBound(vA, 2): UBC = UBound(vA, 2)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC))
    Case Else 'unable to print more dimensions
        MsgBox "Too many dimensions - closing"
        Exit Function
    End Select

    'transfer array values to worksheet
        rng.Value = vA
    
    'release object variables
    Set oSht = Nothing
    Set rng = Nothing
    
    'returns
    Arr1Dor2DtoWorksheet = True

End Function

Function TransposeArray2D(vA As Variant, Optional vR As Variant) As Boolean
        
    '---------------------------------------------------------------------------------
    ' Procedure : Transpose2DArr
    ' Purpose   : Transposes a 2D array; rows become columns, columns become rows
    '             Specifically, (r,c) is moved to (c,r) in every case.
    '             Options include, returned in-place with the source changed, or
    '             if vR is supplied, returned in that instead, with the source intact.
    '---------------------------------------------------------------------------------
    
    Dim vW As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim r As Long, c As Long, bWasMissing As Boolean
    
    'find whether optional vR was initially missing
    bWasMissing = IsMissing(vR)
    If Not bWasMissing Then Set vR = Nothing
    
    'use a work array
    vW = vA
    
    'find bounds of vW data input work array
    loR = LBound(vW, 1): hiR = UBound(vW, 1)
    loC = LBound(vW, 2): hiC = UBound(vW, 2)
    
    'set vR dimensions transposed
    'Erase vR 'there must be an array in the variant to erase
    ReDim vR(loC To hiC, loR To hiR)
    
    'transfer data
    For r = loR To hiR
        For c = loC To hiC
            'transpose vW into vR
            vR(c, r) = vW(r, c)
        Next c
    Next r
    
    'find bounds of vW data input work array
'    loR = LBound(vR, 1): hiR = UBound(vR, 2)
'    loC = LBound(vR, 2): hiC = UBound(vR, 2)


TRANSFERS:
    'decide whether to return in vA or vR
    If Not bWasMissing Then
        'vR was the intended return array
        'so leave vR as it is
    Else:
        'vR is not intended return array
        'so reload vA with vR
        vA = vR
    End If
    
    'return success for function
    TransposeArray2D = True
    
End Function

Sub testCellRefConversion()
    'run this to cell reference conversions
     
    Dim nNum As Long, sLet As String
    
    'set input values here
    nNum = 839
    sLet = "AFG"
    
    MsgBox ConvColAlphaToNum(sLet)

    MsgBox ConvColNumToAlpha(nNum)

End Sub

Function ConvColAlphaToNum(ByVal sColAlpha As String) As Long
    'Converts an Excel column reference from alpha to numeric
    'For example, "A" to 1, "AFG" to 839 etc

    Dim nColNum As Long
    
    'get the column number
    nColNum = Range(sColAlpha & 1).Column
   
    'output to function
    ConvColAlphaToNum = nColNum
    
End Function

Function ConvColNumToAlpha(ByVal nColNum As Long) As String
    'Converts an Excel column reference from numeric to alpha
    'For example, 1 to "A", 839 to "AFG" etc

    Dim sColAlpha As String, vA As Variant
    
    'get the column alpha, in form $D$14
    sColAlpha = Cells(1, nColNum).Address
    
    'split the alpha reference on $
    vA = Split(sColAlpha, "$")
      
    'output second element (1) of array to function
    ConvColNumToAlpha = vA(1) 'array is zero based
  
End Function

Sub DeleteAllWorkbookCharts()
    'run this manually to delete all charts
    'not at this stage called in any procedure
        
    Dim oC
    
    Application.DisplayAlerts = False
    For Each oC In ThisWorkbook.Charts
        oC.Delete
    Next oC
    Application.DisplayAlerts = True
    
End Sub

Sub FormatCells(sSht As String)
    ' Applies certain formats to all cells
    ' of the named parameter sheet
    
    Dim oSht As Worksheet
    
    Set oSht = ThisWorkbook.Worksheets(sSht)
    oSht.Activate
    
    'format all cells of the worksheet
    oSht.Cells.Select
    With Selection
        .Font.Name = "Consolas"
        .Font.Size = 20
        .Columns.AutoFit
        .Rows.AutoFit
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    oSht.Range("A1").Select

End Sub

Sub testFormatRange()
    'place some text in cell 1,1 of sheet1
    
    Dim oSht As Worksheet, Rng As Range

    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    
    Set Rng = oSht.Cells(1, 1)
    
    FormatRange Rng, "autocols"
    Rng.Select
    
    Set Rng = Nothing

End Sub

Sub FormatRange(ByRef rRange As Range, ByVal sOpt As String)
    ' Applies certain formats to
    ' the parameter range of cells
    ' in accordance with selected option
    
    With rRange
        Select Case LCase(sOpt)
            Case "consolas"                     'make monospaced
                .Font.Name = "Consolas"
            Case "calibri"                      'make non-mono
                .Font.Name = "Calibri"
            Case "autocols"                     'autofit column width
                .Columns.AutoFit
            Case "noautocols"                   'default column width
                .ColumnWidth = 8.43
            Case "hcenter"                      'center text horizontally
                .HorizontalAlignment = xlCenter
            Case "hleft"                        'left text horizontally
                .HorizontalAlignment = xlLeft
            Case "bold"                         'bold text
                .Font.Bold = True
            Case "nobold"                       'normal weight text
                .Font.Bold = False
            Case "italic"                       'italic text
                .Font.Italic = True
            Case "noitalic"                     'non-italic text
                .Font.Italic = False
            Case "underline"                    'underlined text
                .Font.Underline = xlUnderlineStyleSingle
            Case "nounderline"                  'non-underlined text
                .Font.Underline = xlUnderlineStyleNone
            Case Else
        End Select
    End With

End Sub

Sub testClearWorksheet()
    'run this to test worksheet clearing
    
    If SheetExists("Sheet1") Then
        ClearWorksheet "Sheet11", 3
    Else 'do other stuff
    End If

End Sub

Function ClearWorksheet(ByVal sSheet As String, ByVal nOpt As Integer) As Boolean
   'clears worksheet contents, formats, or both
   'nOpt options: contents=1, formats=2, all=3
      
   Dim oWSht As Worksheet
   Set oWSht = ThisWorkbook.Worksheets(sSheet)
   oWSht.Activate
      
   With oWSht.Cells
    Select Case nOpt
        Case 1 'contents only
            .ClearContents
        Case 2 'formats only
            .ClearFormats
        Case 3 'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearWorksheet - closing"
        Exit Function
    End Select
   End With
   oWSht.Cells(1, 1).Select
   
   ClearWorksheet = True

End Function

Sub testClearRange()
    'place some text in cell 1,1 of sheet1
    
    Dim oSht As Worksheet, Rng As Range

    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    
    Set Rng = oSht.Cells(1, 1)
    
    ClearRange Rng, "all"
    Rng.Select
    
    Set Rng = Nothing

End Sub

Sub ClearRange(ByRef rRng As Range, Optional ByVal sOpt As String = "contents")
   'clears cell range contents, formats, or both
   'sOpt options: "contents", "formats", or "all"
   'sOpt is optional, default "contents".
   
   With rRng
    Select Case LCase(sOpt)
        Case "contents"  'contents only
            .ClearContents
        Case "formats"   'formats only
            .ClearFormats
        Case "all"       'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearRange - closing"
        Exit Sub
    End Select
   End With
      
End Sub

See Also[edit | edit source]

External Links[edit | edit source]


Worksheet Common Utilities

Summary[edit | edit source]

The procedures on this page are made for Microsoft Excel, and include commonly used worksheet utilities.

The VBA Code[edit | edit source]

Modifications to Code[edit | edit source]

Does Worksheet Exist?[edit | edit source]

Before making a worksheet or referring to one that is assumed to exist, it is best to be certain one way or the the other. This routine returns True if there is already a worksheet with the parameter's name.

Sub testSheetExists()
    'run to test existence of a worksheet
    
    If SheetExists("Sheet1") Then
        MsgBox "Exists"
    Else: MsgBox "Does not exist"
    End If

End Sub

Function SheetExists(ByVal sSheetName As String) As Boolean
    'Return true if sheet already exists
    
    On Error Resume Next
        'exists if its name is not the null string
        SheetExists = (Sheets(sSheetName).Name <> vbNullString)
    On Error GoTo 0

End Function

Add a Named Worksheet[edit | edit source]

This routine adds a worksheet with a specified name. First make sure however that the worksheet name is not in use; see SheetExists().

Sub testAddWorksheet()

    AddWorksheet ("Sheet1")

End Sub

Function AddWorksheet(ByVal sName As String) As Boolean
    'adds a Worksheet to ThisWorkbook with name sName

    With ThisWorkbook
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sName
    End With

    AddWorksheet = True

End Function

Changing Column References[edit | edit source]

At times it is useful to have routines to change the column alpha reference style to a numerical one, and vice versa. These procedures to that.

Sub testCellRefConversion()
    'run this to test cell reference conversions
     
    Dim nNum As Long, sLet As String
    
    'set input values here
    nNum = 839
    sLet = "AFG"
    
    MsgBox ConvColAlphaToNum(sLet)

    MsgBox ConvColNumToAlpha(nNum)

End Sub

Function ConvColAlphaToNum(ByVal sColAlpha As String) As Long
    'Converts an Excel column reference from alpha to numeric
    'For example, "A" to 1, "AFG" to 839 etc

    Dim nColNum As Long
    
    'get the column number
    nColNum = Range(sColAlpha & 1).Column
   
    'output to function
    ConvColAlphaToNum = nColNum
    
End Function

Function ConvColNumToAlpha(ByVal nColNum As Long) As String
    'Converts an Excel column reference from numeric to alpha
    'For example, 1 to "A", 839 to "AFG" etc

    Dim sColAlpha As String, vA As Variant
    
    'get the column alpha, in form $D$14
    sColAlpha = Cells(1, nColNum).Address
    
    'split the alpha reference on $
    vA = Split(sColAlpha, "$")
      
    'output second element (1) of array to function
    ConvColNumToAlpha = vA(1) 'array is zero based
  
End Function

Next Free Row or Column[edit | edit source]

These procedures find the next free column or row. One set selects the cell in question while the other set simply return its position. Examples exist for both columns and rows, and in the absence of a chosen parameter, column 1 or row 1 is assumed.

Sub testFindingNextCells()
    'run this to test next-cell utilities
    'Needs a few cols and rows of data in sheet1

    'deselect to test
    SelectNextAvailCellinCol 1
    'MsgBox RowNumNextAvailCellinCol(1)
    'SelectNextAvailCellinRow 6
    'MsgBox ColNumNextAvailCellinRow(1)

End Sub

Function SelectNextAvailCellinCol(Optional ByVal nCol as Long = 1) As Boolean
    'Selects next available blank cell
    'in column nCol, when approached from sheet end
        
    Cells(Rows.Count, nCol).End(xlUp).Offset(1, 0).Select

End Function

Function RowNumNextAvailCellinCol(Optional ByVal nCol As Long = 1) As Long
    'Returns next available blank cell's row number
    'in column nCol, when approached from sheet end
    
    RowNumNextAvailCellinCol = Cells(Rows.Count, nCol).End(xlUp).Offset(1, 0).Row

End Function

Function SelectNextAvailCellinRow(Optional ByVal nRow as Long = 1) As Boolean
    'Selects next available blank cell
    'in row nRow, when approached from sheet right
        
    Cells(nRow, Columns.Count).End(xlToLeft).Offset(0, 1).Select

End Function

Function ColNumNextAvailCellinRow(Optional ByVal nRow As Long = 1) As Long
    'Returns next available blank cell column number
    'in row nRow, when approached from sheet right
    
    ColNumNextAvailCellinRow = Cells(nRow, Columns.Count).End(xlToLeft).Offset(0, 1).Column

End Function

Clear Worksheet Cells[edit | edit source]

This procedure makes a selective clear of the specified worksheet, depending on the parameter nOpt. The options as coded include, clear contents, (that is the text), clear formats, (the fonts and colours), and clear all, a combination of the two.

Sub testClearWorksheet()
    'run this to test worksheet clearing
    
    If SheetExists("Sheet1") Then
        ClearWorksheet "Sheet11", 3
    Else 'do other stuff
    End If

End Sub

Function ClearWorksheet(ByVal sSheet As String, ByVal nOpt As Integer) As Boolean
   'clears worksheet contents, formats, or both
   'nOpt options: contents=1, formats=2, all=3
      
   Dim oWSht As Worksheet
   Set oWSht = ThisWorkbook.Worksheets(sSheet)
   oWSht.Activate
      
   With oWSht.Cells
    Select Case nOpt
        Case 1 'contents only
            .ClearContents
        Case 2 'formats only
            .ClearFormats
        Case 3 'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearWorksheet - closing"
        Exit Function
    End Select
   End With
   oWSht.Cells(1, 1).Select
   
   ClearWorksheet = True

End Function

Sub testClearRange()
    'place some text in cell 1,1 of sheet1
    
    Dim oSht As Worksheet, Rng As Range

    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    
    Set Rng = oSht.Cells(1, 1)
    
    ClearRange Rng, "all"
    Rng.Select
    
    Set Rng = Nothing

End Sub

Sub ClearRange(ByRef rRng As Range, Optional ByVal sOpt As String = "contents")
   'clears cell range contents, formats, or both
   'sOpt options: "contents", "formats", or "all"
   'sOpt is optional, default "contents".
   
   With rRng
    Select Case LCase(sOpt)
        Case "contents"  'contents only
            .ClearContents
        Case "formats"   'formats only
            .ClearFormats
        Case "all"       'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearRange - closing"
        Exit Sub
    End Select
   End With
      
End Sub

Move Rows and Columns[edit | edit source]

At times it is useful to shift entire columns and rows of data by one place on the spreadsheet, and in any case the process can be repeated as often as is necessary. These procedures assume that the user has first placed the cursor in the column or row of interest. The columns feature is of particular use when bringing an external tabulation into the worksheet; the columns will almost certainly need to be rearranged to match those of the resident set. Food databases are notorious for their different formats, none matching the sequence of those on food labels. Hopefully, some day a product's food data could be entered all at once with a scanned image.

Sub MoveRowDown()
    'moves entire row with cursor down by one place
    'works by moving next row up by one place
    'includes all formats    
    
    Range(ActiveCell.Row + 1 & ":" & ActiveCell.Row + 1).Cut
    ActiveCell.EntireRow.Insert xlShiftDown
    ActiveCell.Offset(1, 0).Select
    
End Sub

Sub MoveRowUp()
    'moves entire row with cursor up by one place
    'includes all formats
    
    If ActiveCell.Row > 1 Then
        Range(ActiveCell.Row & ":" & ActiveCell.Row).Cut
        ActiveCell.Offset(-1, 0).Select
        ActiveCell.EntireRow.Insert xlShiftDown
    Else
        MsgBox "Already at top"
    End If
    
End Sub

Sub MoveColLeft()
    'moves entire column with cursor left one place
    'includes all formats
        
        Dim sColAlpha As String, vA As Variant
        Dim sCol As String
    
        If ActiveCell.Column > 1 Then
            'get the alpha reference for the column
            sColAlpha = Cells(1, ActiveCell.Column).Address
            vA = Split(sColAlpha, "$")
            sCol = vA(1) 'array zero based
            
            'then do the cut and insert
            Range(sCol & ":" & sCol).Cut
            ActiveCell.Offset(0, -1).Select
            ActiveCell.EntireColumn.Insert Shift:=xlShiftToRight
        Else
            MsgBox "Already at extreme left"
        End If
    
End Sub

Sub MoveColRight()
    'moves entire column with cursor right one place
    'works by moving next column left one place
    'includes all formats
        
        Dim sColAlpha As String, vA As Variant
        Dim sCol As String
            
        'get the alpha reference for the next column right
        sColAlpha = Cells(1, ActiveCell.Column + 1).Address
        vA = Split(sColAlpha, "$")
        sCol = vA(1) 'array zero based
        
        'then do the cut and insert to left for next col
        Range(sCol & ":" & sCol).Cut
        ActiveCell.Select
        ActiveCell.EntireColumn.Insert Shift:=xlShiftToRight
        ActiveCell.Offset(0, 1).Select

End Sub

Delete Various Worksheet Items[edit | edit source]

These procedures allow deletion of worksheets, rows, and columns. Before deleting a worksheet, it should first be confirmed to exist.

Sub testDeleteItems()
    'run to test item deletion
    
    'MsgBox DeleteRow(6, "Sheet1")
    'MsgBox DeleteCol(3, "Sheet1")
    MsgBox DeleteSheet("Sheet4")
     
End Sub
 
Function DeleteSheet(ByVal nSht As String) As Boolean
    'Returns true if nSht deleted else false
    'Check first if sheet exists before running this
    'No confirmation dialog will be produced
    
    Application.DisplayAlerts = False 'avoids confirm box
        DeleteSheet = ThisWorkbook.Worksheets(nSht).Delete
    Application.DisplayAlerts = True

End Function

Function DeleteRow(ByVal nRow As Long, ByVal sSht As String) As Boolean
    'Returns true if nRow deleted else false
    'No confirmation dialog will be produced
    
    DeleteRow = ThisWorkbook.Worksheets(sSht).Rows(nRow).Delete

End Function

Function DeleteCol(ByVal nCol As Long, ByVal sSht As String) As Boolean
    'Returns true if nCol deleted else false
    'No confirmation dialog will be produced
    
    DeleteCol = ThisWorkbook.Worksheets(sSht).Columns(nCol).Delete

End Function

See Also[edit | edit source]

{bookcat}


VBA Code to Read ASCII Log Data from LAS File

Summary[edit | edit source]

This page lists a VBA Sub procedure to read data from a LAS file. A LAS file is an industry-standard binary format for storing airborne LIDAR data. Sub procedure requirements:

  • A LAS file must be located in the same folder where the macro-enabled Excel file is located
  • The active worksheet must have in cell A1 the name of the LAS file

VBA Code[edit | edit source]

Sub ReadProperties()
  Dim numWords As Long
  Dim stringLine As String, fileName As String, lineStringVector() As String, headerStart As String
  Dim n As Long, i As Long, numLineHeader As Long, lenStringVector As Long, j As Long
  Dim colStart As Long, numProp As Long
  Dim rowStart As Long, rowNumCounter As Long, numDepths As Long
  Dim StartDatProp As Range, dataArray(1 To 10000, 1 To 20) As Double

  fileName = Cells(1, 1).Value
  Cells(1, 2).Value = "Num Prop:": Cells(1, 4).Value = "Num Depths"
  
  n = 0: rowStart = 2: colStart = 2: rowNumCounter = 1

  Open fileName For Input As 1
  Do While Not EOF(1)
    Line Input #1, stringLine
    headerStart = Left(stringLine, 2) ' stores in headerStart the first two characters of the string stringLine
    If headerStart = "~A" Then
       numLineHeader = n + 1
       lineStringVector() = Split(Trim(stringLine), " ")
       lenStringVector = UBound(lineStringVector) - LBound(lineStringVector) + 1
       numWords = 0: j = 1
       For i = 0 To lenStringVector - 1
          If lineStringVector(i) <> "" Then
             numWords = numWords + 1
             Cells(rowStart, j).Value = lineStringVector(i)
             j = j + 1
          End If
       Next i
       numProp = numWords - 1
       Cells(1, 3).Value = numProp
    End If
    If numLineHeader > 0 And n >= numLineHeader Then
      lineStringVector() = Split(Trim(stringLine), " ")
      lenStringVector = UBound(lineStringVector) - LBound(lineStringVector) + 1
      j = 0
      For i = 0 To lenStringVector - 1
            If lineStringVector(i) <> "" Then
               Cells(rowStart + rowNumCounter, colStart + j).Value = lineStringVector(i)
               dataArray(rowNumCounter, j + 1) = lineStringVector(i)
               j = j + 1
            End If
      Next i
      rowNumCounter = rowNumCounter + 1
    End If
    n = n + 1
  Loop
  Close 1
  numDepths = rowNumCounter - 1
  Cells(1, 5).Value = numDepths
  Cells(rowStart, 2).Select
  Range(Selection, Selection.End(xlDown)).Select
  Range(Selection, Selection.End(xlToRight)).Select
  Selection.NumberFormat = "0.000"
  Cells(rowStart, 2).Select
End Sub

Example Data to Test[edit | edit source]

You may create a ASCII file with extension LAS using the following example of data.

Screenshot showing content of LAS file
Screenshot showing data in LAS file

Output on worksheet after running VBA Sub[edit | edit source]

Screenshot showing Excel active worksheet after running VBA Sub
Shows screenshot of Excel worksheet