Excel & Access VBA blog

Handpicked Examples

On this blog I add random but select VBA functions, subprocedures and subroutines that I'd consider similar or comparable to the ones that I used over time to resolve various automation issues in Excel and Access via VBA based macros to handle challenging tasks that I had to grapple with at work.  I gather these code snippets from around multiple sources and display them here as kind of a collection of code library to provide a showcase of how I utilized VBA in real life and also as a reference source. 

Search through a two-dimension Matrix with the VLOOKUP-Function

'Place the code below into the standard module
Sub ArrayTest()
Dim arrValue(1 To 100, 1 To 2) As Integer
Dim varTest As Variant
Dim intCounter As Integer, intTest As Integer
intTest = CInt(InputBox("Controldigit enter:", , 5))
For intCounter = 1 To 100
arrValue(intCounter, 1) = intCounter
arrValue(intCounter, 2) = intCounter * 10
Next intCounter
varTest = Application.VLookup(intTest, arrValue, 2, 0)
If IsError(varTest) Then
Beep
MsgBox "Value Not Found!"
Else
MsgBox "Value: " & varTest
End If
End Sub

With a user defined function, determine text, address and sub address of a hyperlink.

'Place the following user defined function in a standard VBA module 

Function SplitHype(rng As Range, iInfo As Integer)
Select Case iInfo
Case 0: SplitHype = rng.Value
Case 1: SplitHype = rng.Hyperlinks(1).Address
Case 2: SplitHype = rng.Hyperlinks(1).SubAddress
End Select
End Function

Count only colored cells

'Place the below UDF(user defined function)in a standard VBA module.

Function CountColor(rng As Range, iColor As Integer)
Dim rngAct As Range
Dim iCount As Integer
For Each rngAct In rng.Cells
If rngAct.Interior.ColorIndex = iColor And _
Not IsEmpty(rngAct) Then
iCount = iCount + 1
End If
Next rngAct
CountColor = iCount
End Function

Formula is =countcolor(A1:C6,6)

Ascertain if a File exists in a Directory

'Place the code below into the standard module
Sub File_exists()
Dim dName$
dName = "c:exceltest.xls"
If Dir(dName) <> "" Then
MsgBox dName & " exists!"
Else
MsgBox dName & " does not exist!"
End If
End Sub

VLOOKUP on a Closed Workbook

'Place the code below into the standard module

Sub Reference()

Range("A2").Formula = _

"=VLOOKUP(A1,'c:excel[test1.xls]Sheet1'!A1:B4,2,0)"

End Sub

Construct an Array Formula in VBA

'Place the code below into the standard module

Sub BuildSum()

   Dim z%, i%

   Cells(20, 8).Select

   z = ActiveCell.Row

   For i = 1 To 7

       Cells(z - 1 + i, 6).FormulaArray = _

           "=SUM((r2c1:r23c2=1)*(r2c3:r23c3=" & i & ")*(r2c[-2]:r23c[-2]))"

   Next i

End Sub

Auto Update Sorted List

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A5")) Is Nothing Then
    Range("A1:A5").Sort Range("A1"), xlAscending, Header:=xlYes
End If
End Sub 

XLOOKUP FUNCTION

Microsoft added this long anticipated function to Excel early part of the 2020.  XLOOKUP replaces the old VLOOKUP and offers a whole lot more power and flexibility.  I added to Sample Excel Macros section a file to illustrate various different ways of utilizing this valuable function.

How to Compare Two Data Ranges in Excel

On my Projects > Sample Excel Files section I added a file RangeComparison1.xlsx.  If curious you may want to open this file and check it for yourself.  Change a cell value anywhere in either of the ranges on Sheet1 or Sheet2 then click on the button located on Sheet1.  If there is a change i.e. ranges are not identical then VBA will generate another Excel file indicating where the difference is and will highlight in red color, if data is exactly the same then VBA will tell you that as well.  There were times that I had to deal with comparing two data sets and tried to use many convoluted and cumbersome formula based methods after I got sick and tired of that process and I have started using this method where applicable.

Convert all external links from formulas into values

Put the below code in a standard module then assign it to a button. Sub Link2Value()
   Dim rng As Range
   For Each rng In ActiveSheet.UsedRange.Cells
      If rng.HasFormula Then
         If InStr(rng.Formula, "[") Then
            rng.Value = rng.Value
         End If
      End If
   Next rng
End Sub

Extract Year from Text

Extracting a year from text is possible using string functions if the location of the year is fixed in the text within each cell. But in a free form sentence where the year is used anywhere according to the context there is no way of knowing where in the cell the year is located.  In this case UDF (user defined function) created in VBA solves the issue and it is stored like another Excel built-in function so typing the name of this function is sufficient in the fomula line.  Refer to the file on macro samples for this example called ExtractYerFromText.xls.  Below is the code used to create the said UDF.
Function GetYear(txt As String) As Integer
   Dim intCounter As Integer
   txt = txt & " "
   For intCounter = 1 To Len(txt) - 4
      If Mid(txt, intCounter, 5) Like "*#### *" Then
         GetYear = Mid(txt, intCounter, 4)
         Exit Function
      End If
   Next intCounter
End Function

Note - - UDF as entered would be   =GetYear(A2)


Assigned to a forms button:

Sub YearCaller()
   Dim x As Integer
   x = GetYear(Range("A2").Value)
   MsgBox x
End Sub

Hide Empty Rows on Print

Use this code block in the standard module to print the range without blank rows in it. 
Sub PrintRows()
    Dim TB As Worksheet
    Dim i%, lRow%
    Application.ScreenUpdating = False
    Set TB = Worksheets("Sheet1")
    lRow = TB.[a16384].End(xlUp).Row
    For i = 1 To lRow
        If IsEmpty(TB.Cells(i, 1)) Then TB.Rows(i).EntireRow.Hidden = True
    Next i
    TB.PrintPreview
    TB.Range(TB.Cells(1, 1), TB.Cells(lRow, 1)).EntireRow.Hidden = False
Application.ScreenUpdating = True
End Sub

www.rayerden.com