VBA

Efficient, Minimal Coding Techniques for Project Work

Here are some of my fast, efficient Coding Techniques using Visual Basic for Applications. Highlight the Code with the Mouse and press CTRL+C to copy to the Clipboard. To start, I have provided a list of common 32 Bit And 64 Bit API Declarations For VBA Developers. If you have used any of my work and wish to donate, you can do so on my Donate Page



32 Bit And 64 Bit API Declarations For VBA Developers

Here is a list of 32bit & 64bit API Declarations for VBA Developers - Copy and Paste them into your Code Modules. Change the Private declaration to Public if required. Here is a File that contains Declare statements for Visual Basic for Applications and Microsoft Office 2010 Win32API_PtrSafe.:

Remember sometime you may need to declare Variables as LongPtr for the return type

#If VBA7 And Win64 Then
' 64bit API Declarations
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function MoveWindow Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal X As LongPtr, ByVal Y As LongPtr, ByVal nWidth As LongPtr, ByVal nHeight As LongPtr, ByVal bRepaint As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLongPtr As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal crKey As LongPtr, ByVal bAlpha As Byte, ByVal dwFlags As LongPtr) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFilename As String) As LongPtr
Private Declare PtrSafe Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFilename As String) As LongPtr
Private Declare PtrSafe Function AddFontMemResourceEx Lib "Gdi32.dll" (ByVal pbFont As LongPtr, ByVal cbFont As Integer, ByVal pdv As Integer, ByRef pcFonts As Integer) As LongPtr
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" Alias "SelectObject" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SetTextColor Lib "gdi32" Alias "SetTextColor" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" Alias "DestroyWindow" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetParent Lib "user32" Alias "SetParent" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function InitCommonControlsEx Lib "COMCTL32" (lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean
Private Declare PtrSafe Sub InitCommonControls Lib "COMCTL32" ()
#Else
' 32bit API Declarations
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function MoveWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFilename As String) As Long
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFilename As String) As Long
Private Declare Function AddFontMemResourceEx Lib "gdi32" (ByVal pbFont As Integer, ByVal cbFont As Integer, ByVal pdv As Integer, ByRef pcFonts As Integer) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function SelectObject Lib "gdi32" ( ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" ( ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" ( ByVal fHeight As Long, ByVal fWidth As Long, ByVal fEscapement As Long, ByVal fOrientation As Long, ByVal fWeight As Long, ByVal fItalic As Long, ByVal fUnderline As Long, ByVal fStrikeout As Long, ByVal fCharacterSet As Long, ByVal fPrecision As Long, ByVal fClipping As Long, ByVal fQuality As Long, ByVal fPitchAndFamily As Long, ByVal fName As String) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, rectangle As RECT) As Boolean
Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" ( ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" ( ByVal hwnd As Long) As Long
Private Declare Function SetParent Lib "user32" ( ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
#End If

' required by some of the above libraries
Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
 left As Long
 top As Long
 right As Long
 bottom As Long
End Type



Core Subroutines & Functions

These are some of the Subroutines and Functions I still use today - just Copy the Code into your Projects. Tip: use CTRL+F to search for Code
mdlCoreSubroutines.bas





Removing Row Duplicates

If you have a list of repeated Items including the Header, you can use the following Code to remove the Row duplicates:

' using an OffSet to exclude Headers
Range("A1").CurrentRegion.Offset(1, 0).RemoveDuplicates (Array(1))

' using Short Notation and include/exclude Headers
[A:A].RemoveDuplicates Columns:=1, Header:=xlNo
[A:A].RemoveDuplicates Columns:=1, Header:=xlYes

' and further shortened (Headers excluded by default)
Columns(1).RemoveDuplicates Columns:=1
[A:A].RemoveDuplicates Columns:=1



Replacing Zeros with Blanks

If you have zeros included in a data extract, you can set these to Blank using the following (you can use Columns or a Range):

' Columns, default replace zero (0) with blanks
Columns("A:D").Replace What:="0", Replacement:=""

' Columns, default replace negatives with zero (0)
Columns("I:I").Replace What:="-*", Replacement:="0"

' extended, look at whole Cells, Match Case etc.
Columns("A:D").Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

' Rows, extended, look at whole Cells
Rows("1:5").Replace What:="0", Replacement:="", LookAt:=xlWhole

' Range, simple, replace all zeros (0) with Blanks
Range("A1:B4").Replace What:="0", Replacement:=""

' Defined Name or Named Range
[MyRange].Replace What:="0", Replacement:="", LookAt:=xlWhole





The Quickest Method to SUM or Multiply 2 Ranges (with / without zeros) & Write the Results out to Another Range

I searched everywhere looking for a way to do this, saw that someone advised to use INDEX but in a strange way to how you would normally use it using Short Notation with brackets. I took this and used Named Ranges to create this Code that updates the Named Ranges and then performs the calculations:

' here is the simplified version that demonstrates the method but you cannot use VBA Variables ;(
[A3:D3] = [INDEX( A1:D1 + A2:D2 ,0)]
[A3:D3] = [INDEX( A1:D1 * A2:D2 ,0)]

' and this dynamic example uses 3 Defined Names or Named Ranges and will instantly SUM hundreds of values as an Array and then write these out to the new Range
' the Ranges are set dynamically as I loop through thousands of Array Rows
ActiveWorkbook.Names("PI.DHL.IN.Range").RefersTo = Sheets("DHL IN").Range("G" & lngResult + 10 & ":AF" & lngResult + 10)
ActiveWorkbook.Names("PI.PROMO.INTERFACE.Range").RefersTo = Sheets("PROMO INTERFACE").Range("F" & lngY + 8 & ":AF" & lngY + 8)
ActiveWorkbook.Names("PI.DHL.OUT.Range").RefersTo = Sheets("DHL OUT").Range("G" & lngResult + 10 & ":AF" & lngResult + 10)
[PI.DHL.OUT.Range] = [INDEX( PI.DHL.IN.Range + PI.PROMO.INTERFACE.Range ,0)]
[PI.DHL.OUT.Range] = [INDEX( PI.DHL.IN.Range * PI.PROMO.INTERFACE.Range ,0)]



Deleting Rows in a Column for Cells that are Blank

If you have a Column with data and blank Cells, you can delete the blank Rows using this method starting at Cell "A2" or for Column "A" (requires error trap for xlCellTypeBlanks if none exist):

' delete any Rows containing blank Cells in Column 1, "A" (Short Notation method included)  
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

' delete any Rows containing blank Cells in Column A, starting at Cell "A2" (Short Notation method included) 
On Error Resume Next
Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' [A2:A & Cells(Rows.Count, "A").End(xlUp).Row)].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0

' delete any Rows containing blank Cells in the Active Worksheet for the Used Range
On Error Resume Next
ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0





Copy Formula down a dynamic Column Range with or without AutoFill or using FillDown

You can use the following methods to Copy Formula down a dynamic Column Range (these examples assume data is in Column A with a Header & Formulas are in Columns "B:D"):

Dim lngLastRow As Long
lngLastRow = Range("A" & Rows.Count).End(xlUp).Row
' lngLastRow = [A1048576].End(xlUp).Row

' Copy down Formula with AutoFill in Column B to the last Row
Range("B2").AutoFill Destination:=Range("B2:B" & lngLastRow)

' Copy down Formula with AutoFill in Columns "B:D" to the last Row
Range("B2:D2").AutoFill Destination:=Range("B2:D" & lngLastRow)

' Copy down Formula without AutoFill in Column B to the last Row - use the Macro Recorder to get the R1C1 Formula
'  this Formula is entered using the Code and is not already present in the Cell
Range("B2:B" & lngLastRow).FormulaR1C1 = "=ROW(R[-1])&RC[-1]"

' simple - using FillDown to Copy down whatever the Formula is in Cell "B2" down the Column Range
Range("B2:B" & lngLastRow).FillDown

' using FillDown & Formula storage in array so your Formula do not have to be present in the Cells
Dim strFormulas(1 To 2) As Variant
strFormulas(1) = "=A2*9"
strFormulas(2) = "=SUM(A2:B2)"
Range("B2:C2").Formula = strFormulas
Range("B2:C" & lngLastRow).FillDown



Dynamically Iterate a Column Row Range

If you want to dynamically iterate a Column Row Range from the first Cell to the last Cell you can use the following methods:

' continue until blank Cell - includes the Header (change to A2 to avoid this).  no error trapping is made for a single Cell
Dim rngCell As Range
For Each rngCell In Range("A1", Range("A1").End(xlDown))
 MsgBox rngCell.Value2
Next rngCell

' nice & simple, omit the Header & continue to the first blank Cell
Dim rngCell As Range
For Each rngCell In Range(Range("A2"), Range("A1").End(xlDown))
 MsgBox rngCell.Value2
Next rngCell

' simple, omit the Header & continue to the last blank Row
Dim rngCell As Range
For Each rngCell In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Cells
 MsgBox rngCell.Value2
Next rngCell

' another simple one for a Column, starts at "A1" for Column 1 (A), so will include a Header - iterates until the last blank Row
Dim rngCell As Range
For Each rngCell In Range(Columns(1).End(xlDown), Columns(1).End(xlUp))
 MsgBox rngCell.Value2
Next rngCell

' as above but omits the first Cell "A1" in the Column 1 (A) - iterates until the last blank Row
Dim rngCell As Range
For Each rngCell In Range(Columns(1).End(xlDown), Columns(1).End(xlUp).Offset(1, 0))
 MsgBox rngCell.Value2
Next rngCell

' continue to the last blank Row - uses an Offset to allow you to specify the Header, which is not included
Dim rngCell As Range
For Each rngCell In Range(Range("A1").Offset(1, 0), Range("A" & Cells(Rows.Count, "A").End(xlUp).Row))
 MsgBox rngCell.Value2
Next rngCell

' continue to the last blank Row, an alternative version of the Code above
Dim rngCell As Range
For Each rngCell In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row - 1).Offset(1, 0)
 MsgBox rngCell.Value2
Next rngCell

' Iterates the Range of a dynamic Defined Name.  Pros: very easy to understand and small Code.  Cons: you need to add a dynamic Defined Name
' =OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A),1)
' or =OFFSET(Sheet1!$A$2,0,0,COUNTA(Sheet1!$A:$A)-1,1)
' MyDefinedName
Dim rngCell As Range
For Each rngCell In Range("MyDefinedName")
 MsgBox rngCell.Value
Next rngCell





Find Header & Iterate Range Examples

If you have a Header then you can use any of the following methods to find the Header and then iterate the Range:

' =============================================================================================================================================================
' ## Example1
'    Find a Header on the ActiveSheet, build the dynamic Range from the Header down to the last Row in the Header Column & then load the data into a
'    Variant Array - Please Note: slot Lbound(vntData) + 1 skips the actual header.  Pros: will work regardless of Worksheet changes, very safe, neat Coding.
'    Flexible, use a Defined Name (editable Const) instead of Find.  Use With Sheet1, Sheet2, etc. without selecting the Worksheet  Cons: a little more
'    difficult to understand for anyone editing your work at a later date
' =============================================================================================================================================================
Sub Example1()

' // editable
Const HeaderA As String = "Name"

' // vars
Dim rngCell As Range
Dim vntData As Variant

' // get data by Header
With ActiveSheet
'Set rngCell = .Range(HeaderA)
Set rngCell = .Cells.Find(HeaderA, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext, True)
If Not rngCell Is Nothing Then
vntData = .Range(rngCell.Address & ":" & Split(.Cells(, rngCell.Column).Address, "$")(1) & _
            .Range(Split(.Cells(, rngCell.Column).Address, "$")(1) & .Rows.Count).End(xlUp).Row)    ' fill array using dynamic Range
End If
If TypeName(vntData) = "Empty" Then    ' missing Header
MsgBox "The Header '" & HeaderA & "' cannot be found" & vbNewLine & "Process aborted", vbExclamation, ThisWorkbook.Name: Exit Sub
ElseIf TypeName(vntData) = "String" Then    ' Header only
MsgBox "Data for the Header '" & HeaderA & "' cannot be found" & vbNewLine & "Process aborted", vbExclamation, ThisWorkbook.Name: Exit Sub
End If
End With

' // iterate data
Dim lngY As Long
Dim vntItem As Variant
For lngY = LBound(vntData) + 1 To UBound(vntData)
MsgBox vntData(lngY, 1)
Next lngY

' // clean up
Set rngCell = Nothing
Erase vntData    ' optional, resets Array

End Sub



' =============================================================================================================================================================
' ## Example2
'    Build the Range from a hard-coded Cell down to the last Row in the Column & then load the data into a Variant Array.  Pros: easy to understand.
'    Cons: routine is not dynamic and would require Code edit if anything changes on the Worksheet
' =============================================================================================================================================================
Sub Example2()

' // vars
Dim vntData As Variant
Dim lngY As Long

' // get data
With ActiveSheet
vntData = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With

' // iterate data
For lngY = LBound(vntData) To UBound(vntData)
MsgBox vntData(lngY, 1)
Next lngY

' // clean up
Erase vntData    ' optional, resets Array

End Sub

' =============================================================================================================================================================
' ## Example3
'    Find a Header on the ActiveSheet and iterate the Range from the Header down to the last Row in the Worksheet.  Pros: will work regardless of Worksheet
'    changes, allows you to add Formula, allows you to reference Offsets to add or work with other Column data and / or Formula
'    Cons: a blank Cell will stop the routine
' =============================================================================================================================================================
Sub Example3()

' // editable
Const HeaderA As String = "Name"

' // vars
Dim rngCell As Range
Dim rngLastCell As Range
Dim lngRow As Long
Dim intColumn As Integer

' // iterate data
With ActiveSheet
Set rngCell = .Cells.Find(HeaderA, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext, True)
Set rngLastCell = Cells.Find("*", , , , xlByRows, xlPrevious, True)
If Not rngCell Is Nothing And Not rngLastCell Is Nothing Then
lngRow = 2: intColumn = rngCell.Column
While lngRow <= rngLastCell.Row And .Cells(lngRow, intColumn) <> ""
MsgBox .Cells(lngRow, intColumn)
.Cells(lngRow, intColumn).Offset(0, 1).FormulaR1C1 = "=RC[-1]"    ' add a Formula
.Cells(lngRow, intColumn).Offset(0, 1) = .Cells(lngRow, intColumn).Value    ' change to values
lngRow = lngRow + 1
Wend
End If
End With

' // clean up
Set rngCell = Nothing

End Sub

' =============================================================================================================================================================
' ## Example4
'    Iterates a Range from a hard-coded Cell down to the last Row in the Column.  Pros: very easy to understand and small Code.  Cons: routine is not dynamic
'    and would require Code edit if anything changes on the Worksheet
' =============================================================================================================================================================
Sub Example4()

' // vars
Dim rngCell As Range

' // iterate data
With ActiveSheet
For Each rngCell In .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Cells
MsgBox rngCell.Value
Next rngCell
End With

End Sub

' =============================================================================================================================================================
' ## Example5
'    Iterates the Range of a dynamic Defined Name.  Pros: very easy to understand and small Code.  Cons: you need to add a dynamic Defined Name
'    i.e. =OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A),1) or =OFFSET(Sheet1!$A$2,0,0,COUNTA(Sheet1!$A:$A)-1,1) - does not include the header
' =============================================================================================================================================================
Sub Example5()

' // vars
Dim rngCell As Range

' // iterate data
For Each rngCell In Range("Names").Cells
MsgBox rngCell.Value
Next rngCell

End Sub



Finding the Last Row or First/Last Available Blank Row

Here are methods to get the last Row or first/last available Row in a Column Range or on the Active Worksheet:

' last Row, working from the bottom of a Column upwards (therefore the Column can contain blanks & the last Row will still be returned)
MsgBox Cells(Rows.Count, 1).End(xlUp).Row
MsgBox Cells(Rows.Count, "A").End(xlUp).Row
MsgBox ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
MsgBox Range("A" & Rows.Count).End(xlUp).Row
MsgBox Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Rows.Count

' for a Column Range to find the last Row before a blank & the next available blank Cell
MsgBox Range("A1:A" & Range("A1").End(xlDown).Row).Rows.Count
MsgBox Range("A1:A" & Range("A1").End(xlDown).Offset(1, 0).Row).Rows.Count

' anywhere on a Worksheet to find the last Row and the next available blank Row
MsgBox Cells.Find(What:="*", SearchDirection:=xlPrevious).Row
MsgBox Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
MsgBox Cells.Find(What:="*", SearchDirection:=xlPrevious).Offset(1, 0).Row

' find the last Row (will stop at first blank) & the next available Row (Range or Cells methods)
MsgBox Range("A1").End(xlDown).Row
MsgBox Range("A1").End(xlDown).Offset(1, 0).Row
MsgBox Cells(1, 1).End(xlDown).Row
MsgBox Cells(1, 1).End(xlDown).Offset(1, 0).Row

' the last Row or first available Row, working from the bottom of the Column upwards
MsgBox Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
MsgBox Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row

' the last Row or first available Row, working from the bottom of the Column upwards, Worksheet Function
MsgBox Cells(Application.WorksheetFunction.CountA(Columns(1)) + 1, 1).Row
MsgBox Cells(Application.WorksheetFunction.CountA(Columns(1)) + 1, 1).Offset(1, 0).Row

' the last Row and first available blank Row for a Defined Name / Named Range called 'Header'
MsgBox [Header].End(xlDown).Row
MsgBox [Header].End(xlDown).Offset(1, 0).Row
MsgBox Range("Header").End(xlDown).Row
MsgBox Range("Header").End(xlDown).Offset(1, 0).Row

' lastly, using CurrentRegion & UsedRange (may not always be prefferable)
MsgBox Range("A1").CurrentRegion.Rows.Count
MsgBox ActiveSheet.UsedRange.Rows.Count





Finding the Last Column

Here are methods to get the last Column:

' find last Column in Row 1, working backwards
MsgBox Cells(1, Columns.Count).End(xlToLeft).Column

' find last Column in contiguous Range from a Range Cell
MsgBox Range("A1").End(xlToRight).Column

' find the last Column on the Active Worksheet or any Worksheet by using the Worksheet Name
MsgBox Split(Columns(Cells.Find(What:="*", SearchDirection:=xlPrevious).Column).Address(, False), ":")(1)
MsgBox Split(Columns(Sheets("Sheet1").Cells.Find(What:="*", SearchDirection:=xlPrevious).Column).Address(, False), ":")(1)



Outputting a Variant Array to a 2D Worksheet Array

When creating a Variant array using VBA, you can store the contents in the first slot of a 2D array and then output the array as normal to a Worksheet, something like this:

' vars
Dim vntMappedPlant() As Variant
ReDim vntMappedPlant(1 To "Whatever", 1) ' slot 1 for the second Subscript, replace "Whatever" with an integer

' store contents in first Subscript
vntMappedPlant(lngY, 0) = objDict.Item(CStr(vntData(lngY, 1)))

' output to a Worksheet in one go and the contents of the first Subscript will be written, simple ;)
Range("A2:A" & lngLastRow) = vntMappedPlant





A Really Simple Dictionary Example

Here is a really simple way of creating a Dictionary and adding/updating Items - this Code is just for illustration:

' A2:A5 = 1033603, 1033604, 1033605, 1033606
' B2:B5 = Test, Mark, Name, Age
Sub Example()

' vars
Dim objDict As Object
Dim lngY As Long
Dim vntData As Variant

' initialise
Set objDict = CreateObject("Scripting.Dictionary")

' pick up Data
vntData = Range("A2:B5")

' iterate a dummy data array containing 2 Columns of Customer and Plant data ie. "1033603" and "B070"
For lngY = 1 To UBound(vntData)
' add the Customer & Plant to the Dictionary if it does not exist (always try to use Key/Item pairs with Dictionary Objects)
If Not objDict.Exists(vntData(lngY, 1)) Then
  objDict.Add (vntData(lngY, 1)), vntData(lngY, 2)
Else
  ' just update the Plant in the Dictionary for an existing Customer to the last Plant in our vntData array
  objDict.Item(vntData(lngY, 1)) = vntData(lngY, 2)
End If
Next lngY

' test a Customer in the Dictionary
MsgBox objDict.Item(1033603) ' will display "Test"

' clean up
Set objDict = Nothing

End Sub



Working with the Application.WorksheetFunction

You can use the Application.WorksheetFunction in VBA to perform similar tasks as if you were using Formula in Excel. Here are some examples - view a list of all the members (including methods) of the WorksheetFunction object here:

' hard-code an array and locate the Item & Item Index, zero-based index by default ie. "D", 3
' use Option Base 1 if you want the Index to start at 1 ie. "C", 3
Dim vntArray
vntArray = Array("a", "b", "c", "D")
MsgBox "Item: " & vntArray(3) & ", Item Index: " & Application.WorksheetFunction.Match("c", vntArray, 0)

' find the last Row or first available Row in a Column
MsgBox Cells(Application.WorksheetFunction.CountA(Columns(1)) + 1, 1).Row

' returns the last Day of the current Month as a Date Serial converted into a readable Date using the Format() Function
MsgBox Format(Application.WorksheetFunction.EoMonth(Now(), 0), "dddd, dd mmmm yyyy")





Checking for the existence of Data below Headers

Here are methods to check whether data is present below some Headers:

' WorksheetFunction, check below a Range of Headers from "A6:Z (last Row)", will not 'ALERT' if data is entered after a Blank Row
If WorksheetFunction.CountA(Range("A6:Z" & Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row)) = 0 Then _
 MsgBox "Data not found below Headers", vbExclamation, ThisWorkbook.Name

' CurrentRegion, check below a Range of Headers from "A6:Z (last Row)", will 'ALERT' on data even if data is entered after a Blank Row
If Range("A5").CurrentRegion.Offset(1, 0).Rows.Count = 1 Then _
 MsgBox "Data not found below Headers", vbExclamation, ThisWorkbook.Name



Get Data from a Closed Workbook as Special Values very Fast

Here is a Subroutine to pull Data from a Closed Workbook (Pass the Filepath, Filename, Sheet Name, Range and the Sheet that you want to pull the Data into):

' Call the Function, the Range to add the Data to in your ActiveSheet is the same as the Range to pull the Data from the Closed Workbook, but you can easily tweak this
GetValuesFromAClosedWorkbook "C:\users\Paradigm\Desktop", "BloodPressureTracker.xlsx", "Daily Record", "B10:G1000", "Sheet1"

' ## GetValuesFromAClosedWorkbook, retrieves Special Values for data in a Closed Excel Workbook - the last Parameter is the Worksheet where you want to put the data
Private Sub GetValuesFromAClosedWorkbook(ByVal strFilepath As String, ByVal strFilename As String, ByVal strSheet As String, ByVal strRange As String, ByVal strActiveSheet As String)
    With Sheets(strActiveSheet).Range(strRange)
        .FormulaArray = "='" & strFilepath & "\[" & strFilename & "]" & strSheet & "'!" & strRange
        .Value = .Value
    End With
End Sub





Pick up & Concatenate a List of Email Addresses

Pick up and concatenate a list of Email addresses as a semi-colon delimited String (change 'Header' to a Header of your choice). The Code makes the assumption that at least 1 Email Address will be maintained:

MsgBox Join(Application.Transpose(Cells.Find("Header", , xlValues, xlWhole, xlByRows, xlNext, True).CurrentRegion.Offset(1, 0).Resize( _
 Cells.Find("Header", , xlValues, xlWhole, xlByRows, xlNext, True).CurrentRegion.Rows.Count - 1, 1).Value), ";")



Format Column Ranges

Here is my method to get the last Row and then quickly Format Column Ranges:

' derive the last Row of my data Range
Dim lngLastRow As Long
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

' horizontal alignment
Range("A2:A" & lngLastRow).HorizontalAlignment = xlLeft 'xlRight 'xlCenter

' vertical alignment
Range("A2:A" & lngLastRow).VerticalAlignment = xlTop 'xlCenter 'xlBottom

' whole numbers with comma
Range("A2:A" & lngLastRow).NumberFormat = "#,##0"

' numbers with comma, to 1 significant place
Range("A2:A" & lngLastRow).NumberFormat = "#,##0.0"

' percentage % with comma, to 1 significant place
Range("A2:A" & lngLastRow).NumberFormat = "#,##0.0""%"""

' currency, with comma, to 2 significant places
Range("A2:A" & lngLastRow).NumberFormat = "$#,##0.00_);($#,##0.00)"

' whole numbers with comma, with wide bar (em dash) for zero values
Range("A2:A" & lngLastRow).NumberFormat = "#,##0;-#,##0;""—"""

' Date ie. 23/05/2017
Range("A2:A" & lngLastRow).NumberFormat = "m/d/yyyy"

' specific format ie. 5 EQB, 12 BT, 35 CASES
Range("A2:A" & lngLastRow).NumberFormat = "#,##0"" EQB"";" '"#,##0"" BT"";" '"#,##0"" CASES"";"





Iterate Column Range - Format ReSized Row Range with a Fill Colour and a Border Colour

You can use this method without an external Subroutine or Function to iterate a Column Range and format a resized Row Range with a Fill Colour and a Border Colour (you can combine this Code with an Offset if you were iterating a different Column to still pick up the entire Row Range ie. starting in Column "C" you could use rngCell.Offset(0, -3).Resize(1, 10)):

' iterate a Column Range to the first blank Cell and format a resized Column/Row Range with a Fill Colour & Border Colour
Dim rngCell As Range
For Each rngCell In Range("A2", Range("A1").End(xlDown))
 rngCell.Resize(1, 10).Interior.Color = 15724523
 rngCell.Resize(1, 10).Borders(xlEdgeTop).ThemeColor = 1
 rngCell.Resize(1, 10).Borders(xlEdgeBottom).ThemeColor = 1
Next rngCell



Deleting Rows

Use the following Code to delete Rows for a Column containing specific criteria (this matches any of my Materials containing 'CASK' in Column A):

Dim lngLastRow As Long
Dim rngRange As Range
Dim rngDelete As Range

Rows(1).Insert
Range("A1").Value = "Temp"
With ActiveSheet
	lngLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
	Set rngRange = Range("A1", Cells(lngLastRow, "A"))
	rngRange.AutoFilter Field:=1, Criteria1:="*CASK*"
	Set rngDelete = rngRange.SpecialCells(xlCellTypeVisible)
	rngRange.AutoFilter
	rngDelete.EntireRow.Delete
End With
Or use these alternative, shortened versions (the data extract would not typically have an autofilter applied, so we apply one and then remove it):
' quick method to delete Rows containing "CASK" for a dynamic Range in Cell "A1" with Headers
Range("A1", Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, "A")).AutoFilter Field:=1, Criteria1:="*CASK*"
Range("A1").Offset(1).Resize(Cells.SpecialCells(xlCellTypeLastCell).Row).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Range("A1").AutoFilter ' turn off the AutoFilter

' delete any Rows containing "CASK" in Column "A" where your data extract does not contain Headers
Columns(1).AutoFilter Field:=1, Criteria1:="*CASK*"
Columns(1).EntireRow.Delete

' delete any Rows containing "CASK" in Column "A" where your data extract does contain Headers
Columns(1).AutoFilter Field:=1, Criteria1:="*CASK*"
Columns(1).Resize(Cells.SpecialCells(xlCellTypeLastCell).Row).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Columns(1).AutoFilter ' turn off the AutoFilter





Setting AutoFilter Criteria

You can set AutoFilter Criteria by using any of the following methods:

' sets an Autofilter for a Header called 'Name' with the values specified in a hard-coded Range
Range("$I$6:$K$13").AutoFilter Field:=1, Criteria1:=Array("Claire", "Mark", "Tina"), Operator:=xlFilterValues

' sets an Autofilter for a Header called 'Name' with the values specified in a dynamic Range
Range("$I$6:$K$" & Cells(Rows.Count, "I").End(xlUp).Row).AutoFilter Field:=1, Criteria1:=Array("Claire", "Mark", "Tina"), Operator:=xlFilterValues

' dynamically set an AutoFilter using a Range of Criteria.  'A1:A3' =Mark, Claire, Paul in Rows
' - you can use Dim vntArray as Variant, vntArray = Application.Transpose(Range("A1:A3"))
Range("I6").AutoFilter Field:=1, Criteria1:=Application.Transpose(Range("A1:A3")), Operator:=xlFilterValues
 
' same as the above technique but using Short Notation.  'A1:A3' =Mark, Claire, Paul in Rows
[I6].AutoFilter Field:=1, Criteria1:=Application.Transpose([A1:A3]), Operator:=xlFilterValues
 
' dynamically set an AutoFilter using a Range of Criteria.  'A1:A3' '=22, '=23, '=42 in Rows (remember the apostrophe!)
Range("$I$6:$K$" & Cells(Rows.Count, "I").End(xlUp).Row).AutoFilter Field:=2, Criteria1:=Application.Transpose(Range("A1:A3")), Operator:=xlFilterValues
 
' dynamically set an AutoFilter using a Range of Criteria as Custom Filter contains Tina & equals Claire.  'A1:A3' '=Claire, '=*Tina* in Rows (remember the apostrophe!)
Range("$I$6:$K$" & Cells(Rows.Count, "I").End(xlUp).Row).AutoFilter Field:=1, Criteria1:=Application.Transpose(Range("A1:A3")), Operator:=xlFilterValues



Picking up List Data

You can pickup list data underneath a header into a Variant array using the following (change 'Header' to whatever you need to find):

Dim vntData As Variant
vntData = Range(Cells.Find("Header", , xlValues, xlWhole, xlByRows, xlNext, True).Offset(1), Cells.Find("Header", , xlValues, xlWhole, xlByRows, xlNext, True).Offset(1).End(xlDown))





Converting Text to Numbers

You can use the following methods to convert Text to Numbers (I assume the Range is in Column A and contains a Header):

Range(Range("A2"), Range("A2").End(xlDown)).TextToColumns Destination:=Range("A2")

With Range(Range("A2"), Range("A2").End(xlDown))
 .NumberFormat = "General" ' .NumberFormat = "0"
 .Value = .Value
End With



Date & Time Functions

Some useful Date & Time Functions:

' derive the Day of the Week from the current Date/Time as a String ie. "Sunday", "Monday"
Dim strDayOfWeek  As String
strDayOfWeek = Format(Now(), "dddd")





Filtering & Copying Data to another Worksheet using SpecialCells (Special Values or with the original Formatting) & in Multiple Parts

You can use the following method to Select a data extract Worksheet, filter and Copy the data to another Worksheet as Special Values (this also resets the Copy Mode and the AutoFilter):

' 1. simply filter some data on a Worksheet called 'HFA data' by '"Diageo GB Ltd."'
Sheets("HFA data").Select
Range("D1", Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, "D")).AutoFilter Field:=1, Criteria1:="Diageo GB Ltd."

' 2. filter & Copy some data to the respective Worksheet 'Diageo GB Ltd.' as Special Values
Dim lngSpecialRow As Long
lngSpecialRow = Range("D1").Offset(1).Resize(Cells.SpecialCells(xlCellTypeLastCell).Row).SpecialCells(xlCellTypeVisible).Row
Range("A" & lngSpecialRow & ":" & "AB" & lngSpecialRow, Range("A" & lngSpecialRow & ":" & "AB" & lngSpecialRow).End(xlDown)).Copy
Sheets("Diageo GB Ltd.").Range("B8").PasteSpecial Paste:=xlPasteValues ' comment out Paste:=xlPasteValues to Paste the data using the same formats
Application.CutCopyMode = False ' reset the Copy Mode
Sheets("HFA data").Range("D1").AutoFilter ' reset the AutoFilter

' 3. build a truly dynamic Range using SpecialCells in 2 separate parts including setting more than one filter
' - this method does not use xlDown, it builds a proper Range from the visible Special Cells for both parts to Copy
' it Copies the filtered data in 2 parts, from 'Sheet1' to 'Sheet2', omitting Columns 'K' & 'L'
' the Code assumes a Header Range on Sheet1 & Sheet 2 for "$B$2:$BH$" with data in Sheet2
' - you will need to tweak the filters to your own Columns
Dim lngLastRow As Long
Dim lngSpecialRow As Long
Dim lngSpecialLastRow As Long
Dim strRange As String

Sheets("Sheet1").Select
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
strRange = "$B$2:$BH$"

Range(strRange & lngLastRow).AutoFilter Field:=53, Criteria1:="1"
Range(strRange & lngLastRow).AutoFilter Field:=54, Criteria1:="1"
Range(strRange & lngLastRow).AutoFilter Field:=8, Criteria1:="Active Local"
Range(strRange & lngLastRow).AutoFilter Field:=56, Criteria1:="1"

' derive the first & last visible Special Cell Rows
lngSpecialRow = Range("B2").Offset(1).Resize(Cells.SpecialCells(xlCellTypeLastCell).Row).SpecialCells(xlCellTypeVisible).Row
lngSpecialLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

' do part 1 Copy
Range("B" & lngSpecialRow & ":" & "J" & lngSpecialLastRow, Range("B" & lngSpecialRow & ":" & "J" & lngSpecialLastRow)).Copy
Sheets("Sheet2").Range("B9").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

' do part 2 Copy - remember, you don't have to Copy all of the Columns, you could stop as "AS" for example
Range("M" & lngSpecialRow & ":" & "BH" & lngSpecialLastRow, Range("M" & lngSpecialRow & ":" & "BH" & lngSpecialLastRow)).Copy
Sheets("Sheet2").Range("K9").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

' reset the AutoFilter
Range("B2").AutoFilter



Copying Data from one Worksheet to another Worksheet as Special Values using a Subroutine

You can use the following Subroutine to Copy data from one Worksheet to another Worksheet as Special Values:

Call CopyAndPasteFormulaAsSpecialValues(Sheets("Sheet1"), "A1:B1", Sheets("Sheet1"), "A2:B10")

' CopyAndPasteFormulaAsSpecialValues, Copy Formulas from one place to another and then Copy & Paste the calculated results as Special Values
Public Sub CopyAndPasteFormulaAsSpecialValues(ByVal SourceWorksheet As Worksheet, _
                                              ByVal FormulaRangeToCopy As String, _
                                              ByVal DestinationWorksheet As Worksheet, _
                                              ByVal RangeToPasteOver As String)

    ' // ensure some error handling to restore events
    On Error GoTo Catch

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' // Copy the initial Formula from one place to another
    SourceWorksheet.Range(FormulaRangeToCopy).Copy _
            Destination:=DestinationWorksheet.Range(RangeToPasteOver)

    ' // Copy & Paste Special Values over the calculated Formula Range
    DestinationWorksheet.Range(RangeToPasteOver).Copy
    DestinationWorksheet.Range(RangeToPasteOver).PasteSpecial _
            Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Application.CutCopyMode = False
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

Catch:
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub





Converting Column Numbers to Letters

Obtaining Row information is easy since Rows are always Numbers. Column Letters that can be used in a Range are a little more tricky. I have many methods to obtain a Column Letter from a Column Number - here are a few of my favourites:

' 1. simple inline methods for the ActiveCell or for a Column Number
MsgBox Split(ActiveCell.Address, "$")(1)
MsgBox Split(ActiveCell(1).Address(1, 0), "$")(0)
MsgBox Split(ActiveCell.Address(True, False), "$")(0)
MsgBox Mid(ActiveCell.Address, 2, InStr(2, ActiveCell.Address, "$") - 2)
MsgBox Split(Columns(16384).Address(, False), ":")(1)

'1.1 dynamically find the last Column on the ActiveSheet and convert it to a Letter
MsgBox Split(Columns(Cells.Find(What:="*", SearchDirection:=xlPrevious).Column).Address(, False), ":")(1)
MsgBox Split(Columns(Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column).Address(, False), ":")(1)

' 2. an inline method to obtain the last Column Letter in a Range ie. a Row of Headers
Dim strLastColumn as string
strLastColumn = Split(Cells(1, Range("A1").End(xlToRight).Column).Address(True, False), "$")(0)

' 3. a Function that returns the Column Letter for any Column Number
Dim strColumn as String
strColumn = GetColumnLetter(1)
	
Public Function GetColumnLetter(ByVal MyColumnNumber As Integer) As String
	GetColumnLetter = Left(Cells(1, Int(MyColumnNumber)).Address(1, 0), InStr(1, Cells(1, Int(MyColumnNumber)).Address(1, 0), "$") - 1)
End Function



Get Column Letter And Row Number From Both Parts Of A Range

Here are some basic methods to get a Column Letter & Row Number from both parts of a Range ie. "A1:B2". The examples below will result in Column "A", Row "1", Column "B" & Row "2". This can be very useful when building dynamic Ranges:

' // select a Range for the Example
Range("A1:B2").Select

' // identify the Column for the first part of the Range following the ":"
MsgBox Split(Split(Selection.Address, ":")(0), "$")(1)

' // identify the Row for the first part of the Range following the ":"
MsgBox Split(Split(Selection.Address, ":")(0), "$")(2)

' // identify the Column for the second part of the Range following the ":"
MsgBox Split(Split(Selection.Address, ":")(1), "$")(1)

' // identify the Row for the second part of the Range following the ":"
MsgBox Split(Split(Selection.Address, ":")(1), "$")(2)





Add or Update a Last Saved or Actioned Message into your Workbook

Sometimes you need to know when a File was last saved. Here is a simple, robust method of doing this using the Workbook_BeforeSave() Subroutine to give you a message like this 'last saved: 11/02/2018 09:13:25'. Add the Subroutine below into the ThisWorkbook Code Module of one of your Saved Projects or Files (add the Defined Name shown in brackets if using the first example). Press CTRL+S or Save the File to see the results:

' ## Workbook_BeforeSave, updates the file save date & time - uses a Defined Name or Named Range ie. last saved: 11/02/2018 09:13:25
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    [PI.LastSaved].Value2 = "last saved: " & Format(Now(), "dd/mm/yyyy hh:mm:ss")
End Sub


' ## Workbook_BeforeSave, updates the file save date & time - uses a Defined Name or Named Range ie. last saved: 11/02/2018 09:13:25
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    [PI.LastSaved].Value2 = "last saved: " & Format(Now(), "dd/mm/yyyy hh:mm:ss")
End Sub

' ## Workbook_BeforeSave, updates the file save date & time - uses a Sheet & Range
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Sheets("Sheet1").Range("A1").Value2 = "last saved: " & Format(Now(), "dd/mm/yyyy hh:mm:ss")
End Sub

' add / update a last actioned message ie. last changes applied: 11/02/2018 09:18:15
' add this Code anywhere in a standard Code Module
[PI.LastChanges].Value2 = "last changes applied: " & Format(Now(), "dd/mm/yyyy hh:mm:ss")
Sheets("Sheet1").Range("A1").Value2 = "last changes applied: " & Format(Now(), "dd/mm/yyyy hh:mm:ss")



Get Column Letter From A Cell Address And Increment The Column Letter

Here are some basic methods to get a Column Letter from a single Cell Address and then to increment the Cell Address to get the next Column Letter ie. H7 should return "H" and then "I". This is useful for building dynamic Ranges. I detail 3 ways of declaring the Cell Address Variable:

' // set a Constant
'Const strAddress As String = "H7"
' or... Const strAddress As String = "$H$7"
Dim strAddress As String
strAddress = "H7"

' // output the actual Cell Address
MsgBox Range(strAddress).Address

' // output the initial Column Letter of the Cell Address
MsgBox Split(Range(strAddress).Address(1, 0), "$")(0)

' // output the Next Column Letter (substitute the 1 in the Column Offset(0, 1) to 2 for Column Letter "J")
MsgBox Split(Range(strAddress).Offset(0, 1).Address(1, 0), "$")(0)





Use Regular Expressions (RegEx) to Match a Key & return the Item

Here is a simple Subroutine to show you how to match using a pattern in a String - this allows you to hold a large String in memory or embed it in a Worksheet and then very quickly return the Item for a Key. This example returns 'Bulmers Strongbow KEG 11':

Private Sub RegExMatchTest()

' vars
Dim allMatches As Object
Dim RegExp As Object
Dim result As String
result = "-" ' default return for no match
Set RegExp = CreateObject("VBScript.RegExp")

' set up a dummy String - use a delimiter that will not be found in the Key or Item though
Dim strText As String
strText = "56510@Bulmers Strongbow KEG 11@56615@Guinness Keg 11@"

' match and grab everything in between the 2 '@' characters
RegExp.Pattern = "56510@(.*?)@"
Set allMatches = RegExp.Execute(strText)
If allMatches.Count <> 0 Then
 result = allMatches.Item(0).submatches.Item(0)
End If

' display the Item
MsgBox result

End Sub



Picking up a Range into a Variant Array

You can use the following methods to pick up Range data into a Variant array:

' pick up contiguous Range data from B5 to the end of the Column Range
Dim vntData As Variant
vntData = Range(Range("B5"), Range("B5").End(xlToRight))

' picking up a 2 Column list of Suppliers by finding the Header 'Supplier Report List' on a Worksheet called 'Tables & System'
' the second Offset(1,1) is used to control the Column Width of the Range picked up - omit the Offset to pick up a single list
' the first Offset is used to omit the actual Header
Dim vntSuppliers As Variant
vntSuppliers = Sheets("Tables & System").Range(Sheets("Tables & System").Cells.Find("Supplier Report List", , xlValues, xlWhole, xlByRows, xlNext, True).Offset(1), _
 Sheets("Tables & System").Cells.Find("Supplier Report List", , xlValues, xlWhole, xlByRows, xlNext, True).Offset(1, 1).End(xlDown))

' pick up contiguous Range data from "A1:C1" down to the first Blank Cell in "A1"
Dim vntData As Variant
vntData = Range(Range("A1:C" & Range("A1").End(xlDown).Row).Address).Cells





Highlighting Rows when any Cell is Selected within the Range - Useful for an Instruction Worksheet when completing the Sections

You can use the following Code to highlight Rows when a Cell is Selected. Insert the Code into the Worksheet Code Module (update the Row Ranges as you wish):

Option Explicit

' this Macro will simply highlight the current section that you are working on in, in an 'Instructions' Worksheet
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    ' clear the color of all the cells
    Cells.Interior.ColorIndex = 0

    Select Case Target.Row
        Case 9 To 17
            ActiveSheet.Rows("9:17").EntireRow.Interior.ColorIndex = 8
        Case 18 To 33
            ActiveSheet.Rows("18:33").EntireRow.Interior.ColorIndex = 8
        Case 34 To 47
            ActiveSheet.Rows("34:47").EntireRow.Interior.ColorIndex = 8
    End Select
    Application.ScreenUpdating = True
End Sub



Changing Blank to Zero for Format Calculation on Numbers in One Step

I found that I needed to use a Custom Format on a Value when I wrote it out to a CSV File ie. '15' as '15.000', but I also needed Blanks to be 0 so that I wrote out '0.000'. To avoid doing this using 'If vntDHLFileOUT(lngY, intX) = "" do the Format, otherwise Format a zero' which takes extra time, I found a simple solution - just use '+0':

' will Format a value of Blank or any number ie. 15 = '15.000', Blank or 0 = '0.000'
Format(vntDHLFileOUT(lngY, intX) + 0, "###0.000")





Build a Dynamic Range from a Cell Reference, a Number of Columns & a Number of Rows

Here is the Code to build a dynamic Range from a Cell Reference, a Number of Columns and a Number of Rows:

Dim strCellReference As String
Dim rngRange As Range
Dim intNumberOfColumns As Integer
Dim intNumberOfRows As Long
    
strCellReference = "A1"
intNumberOfColumns = 6
intNumberOfRows = 100
Set rngRange = Range(strCellReference, Range(Left(Cells(1, Int(intNumberOfColumns + Range(strCellReference).Column - 1)).Address(1, 0), _
                InStr(1, Cells(1, Int(intNumberOfColumns + Range(strCellReference).Column)).Address(1, 0), "$") - 1) & Range(strCellReference).Row + intNumberOfRows - 1)).Cells
    
If Not rngRange Is Nothing Then rngRange.Select



Fast Evaluate Match to Find Data in a Column

Here is the Code to return the first Row matched for the String "Hi there, my name is Mark":

Dim strMatch
Dim lngRow As String
strMatch = Chr(34) & "Hi there, my name is Mark" & Chr(34)

On Error Resume Next
lngRow = Evaluate("=MATCH( " & strMatch & ",A:A,0)")
If Err.Number <> 13 Then MsgBox "Found at Row: " & lngRow: Range("A" & lngRow).Select
On Error GoTo 0



Using Evaluate to do some Awesome Stuff

Here is the Code to transfer a range to a variant from one Worksheet to another using Evaluate and swap all the Column orders (courtesy of the small man and Aaron Blood):

Sub MoveCols()
    Dim ar As Variant

    With Sheet1.Cells(1).CurrentRegion
        ar = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), Array(3, 1, 2, 14, 15))
    End With
    Sheet5.Range("A12").Resize(UBound(ar), 5) = ar
End Sub

Here is the Code to filter data in Column "B" less than 10 into Column "C" - requires some data in Column "A":
    Dim ar As Variant
    With Range("a1", Range("a" & Rows.Count).End(xlUp))
        ar = Filter(.Parent.Evaluate("transpose(if((" & .Columns(2).Address & ">=1)*(" & _
                                     .Columns(2).Address & "<=10)," & .Columns(1).Address & ",char(2)))"), Chr(2), 0)
        .Columns(3).Offset(1).Resize(UBound(ar) + 1).Value = Application.Transpose(ar)
    End With

Here are some Evaluate Array examples by Aaron Blood:
Sub Arrays()
     
    Dim xArray() As Variant
     
    ' 1D array string conversion
    xArray = [{1,2,3}]
    Range("A1").Resize(1, UBound(xArray)).Value = xArray
     
    ' 2D array string conversion
    xArray = [{1,2;3,4;5,6}]
    Range("A5").Resize(UBound(xArray, 1), UBound(xArray, 2)).Value = xArray
     
    ' 2D array string conversion with a string variable
    y = "{1,2;3,4;5,6}"
    xArray = Evaluate(y) 'have to be more explicit, the shorthand won't work
    Range("A10").Resize(UBound(xArray, 1), UBound(xArray, 2)).Value = xArray
     
End Sub





How to Display what is AutoFiltered as Text

I like to display what is AutoFiltered as Text in a Cell. I already have a Function in my CORE Subroutines but wanted one a bit better so I came up with 3 Functions. The first one Displays what is AutoFiltered for Criteria1 or displays '[Mult.]' if more than one Criteria is Selected. The second one displays both Criteria1 and Criteria2 plus '[Mult.]' if more than 2 Criteria are Selected. The Third one is the same as the second, but it wraps Criteria1 and Criteria2 in brackets if both Criteria are present - take your pick, all you need to do is pass the Range of Headers (Please Note: the third Function is named the same as the second Function):

For example, add this to a Cell =AutoFilteredHeadersMult($B$8:$BL$8) or =AutoFilteredHeaders($B$8:$BL$8) to display what is AutoFiltered

Returned Examples for the Third Function with Headers 'Name, Age, Sex':
Name=[=Claire, =*Tina*]
Name=[=Claire, =*Tina*], Age=23
Age=[>=21, <=25]
Name[mult.], Age=45, Sex=F

' // will detail what is included in an AutoFilter but will show multiple Criteria in a Filter as [Mult.]
Public Function AutoFilteredHeadersMult(ByVal Header As Range) As String
    On Error GoTo Catch
    ' // vars
    Dim lngY As Long
    Dim strCriteria As String
    Dim strTemp As String
    Dim strTempCriteria As String
    Dim blnCriteria1 As Boolean
    Dim blnCriteria2 As Boolean
    Dim strCriteria1 As String
    Dim strCriteria2 As String
    Application.Volatile

    With Header.Parent.AutoFilter
        For lngY = 1 To .Filters.Count
            With .Filters(lngY)
                blnCriteria1 = True
                blnCriteria2 = True
                On Error Resume Next
                strTemp = .Criteria1
                If Err.Number = 1004 Then blnCriteria1 = False
                Err.Clear
                strTemp = .Criteria2
                If Err.Number = 1004 Then blnCriteria2 = False
                Err.Clear
                If Not blnCriteria1 And Not blnCriteria2 Then
                    ' do nothing
                End If
                If blnCriteria1 And Not blnCriteria2 Then
                    On Error Resume Next
                    strTemp = .Criteria1
                    If Err.Number = 13 Then
                        strCriteria = strCriteria & Header.Cells(1, lngY) & "[mult.], "
                    Else
                        strCriteria = strCriteria & Header.Cells(1, lngY) & .Criteria1 & ", "
                    End If
                    Err.Clear
                End If
                If blnCriteria1 And blnCriteria2 Then
                    strCriteria = strCriteria & Header.Cells(1, lngY) & "[mult.], "
                End If
            End With
        Next lngY
    End With

    AutoFilteredHeadersMult = Mid(strCriteria, 1, Len(strCriteria) - 2)
    Exit Function
Catch:
    AutoFilteredHeadersMult = ""
End Function

' // will detail what is included in an AutoFilter showing 2 Criteria in a Filter and multiple Criteria as [Mult.]
Public Function AutoFilteredHeaders(ByVal Header As Range) As String
    On Error GoTo Catch
    ' // vars
    Dim lngY As Long
    Dim strCriteria As String
    Dim strTemp As String
    Dim strTempCriteria As String
    Dim blnCriteria1 As Boolean
    Dim blnCriteria2 As Boolean
    Dim strCriteria1 As String
    Dim strCriteria2 As String
    Application.Volatile

    With Header.Parent.AutoFilter
        For lngY = 1 To .Filters.Count
            With .Filters(lngY)
                blnCriteria1 = True
                blnCriteria2 = True
                On Error Resume Next
                strTemp = .Criteria1
                If Err.Number = 1004 Then blnCriteria1 = False
                Err.Clear
                strTemp = .Criteria2
                If Err.Number = 1004 Then blnCriteria2 = False
                Err.Clear
                If Not blnCriteria1 And Not blnCriteria2 Then
                    ' do nothing
                End If
                If blnCriteria1 And Not blnCriteria2 Then
                    On Error Resume Next
                    strTemp = .Criteria1
                    If Err.Number = 13 Then
                        strCriteria = strCriteria & Header.Cells(1, lngY) & "[mult.], "
                    Else
                        strCriteria = strCriteria & Header.Cells(1, lngY) & .Criteria1 & ", "
                    End If
                    Err.Clear
                End If
                If blnCriteria1 And blnCriteria2 Then
                    strCriteria = strCriteria & Header.Cells(1, lngY) & .Criteria1 & ", " & .Criteria2 & ", "
                End If
            End With
        Next lngY
    End With

    AutoFilteredHeaders = Mid(strCriteria, 1, Len(strCriteria) - 2)
    Exit Function
Catch:
    AutoFilteredHeaders = ""
End Function

' // will detail what is included in an AutoFilter showing 2 Criteria in a Filter and multiple Criteria as [Mult.]
'    this one will also wrap Criteria1 & Criteria2 in brackets if both are present
Public Function AutoFilteredHeaders(ByVal Header As Range) As String
    On Error GoTo Catch
    ' // vars
    Dim lngY As Long
    Dim strCriteria As String
    Dim strTemp As String
    Dim strTempCriteria As String
    Dim blnCriteria1 As Boolean
    Dim blnCriteria2 As Boolean
    Dim strCriteria1 As String
    Dim strCriteria2 As String
    Application.Volatile
 
    With Header.Parent.AutoFilter
        For lngY = 1 To .Filters.Count
            With .Filters(lngY)
                blnCriteria1 = True
                blnCriteria2 = True
                On Error Resume Next
                strTemp = .Criteria1
                If Err.Number = 1004 Then blnCriteria1 = False
                Err.Clear
                strTemp = .Criteria2
                If Err.Number = 1004 Then blnCriteria2 = False
                Err.Clear
                If Not blnCriteria1 And Not blnCriteria2 Then
                    ' do nothing
                End If
                If blnCriteria1 And Not blnCriteria2 Then
                    On Error Resume Next
                    strTemp = .Criteria1
                    If Err.Number = 13 Then
                        strCriteria = strCriteria & Header.Cells(1, lngY) & "[mult.], "
                    Else
                        strCriteria = strCriteria & Header.Cells(1, lngY) & .Criteria1 & ", "
                    End If
                    Err.Clear
                End If
                If blnCriteria1 And blnCriteria2 Then
                    strCriteria = strCriteria & Header.Cells(1, lngY) & "=[" & .Criteria1 & ", " & .Criteria2 & "], "
                End If
            End With
        Next lngY
    End With
 
    AutoFilteredHeaders = Mid(strCriteria, 1, Len(strCriteria) - 2)
    Exit Function
Catch:
    AutoFilteredHeaders = ""
End Function



Saving out Worksheets & Code Modules as a Single Report as Any File Type ie. *.XLSB with the Option to Delete Specific Workbook Scoped Defined Names that were Scoped to the Workbook being Copied

You can use the following Code to Select, Copy and Save Worksheets as a single Report ie. *.XLSB with the option to delete specific Defined Names or Named Ranges that were scoped to the Workbook being copied. The Code also lets you select a default Cell before any Worksheets are Copied. The Code will Copy VBA Code from a Code Module called mdlSubroutines into the new Workbook to be Saved. Lastly, the Code will add a short notification to the Excel Statusbar - modify the Subroutine to how you need it:

' SaveReport, saves out a Report for the current Week
Private Sub SaveReport()

    ' File Types
    ' 51 = xlOpenXMLWorkbook (without macro's in 2007-2013, xlsx)
    ' 52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2013, xlsm)
    ' 50 = xlExcel12 (Excel Binary Workbook in 2007-2013 with or without macro's, xlsb)
    ' 56 = xlExcel8 (97-2003 format in Excel 2007-2013, xls)

    ' // vars
    Dim strFile As String
    Dim intFileFormatNum As Integer
    Dim objSheet As Worksheet
    Dim n As Name
 
    Application.DisplayAlerts = False

 
    ' // loop by Worksheet Name i.e. "Sheet1", "foobar" etc.
    '    explicit Workbook reference, just set default Cell to tidy up
    For Each objSheet In ThisWorkbook.Worksheets(Array(1, 2, 4, 5)) ' can be "Sheet1", "Sheet2" etc.
        objSheet.Activate
        Range("B8").Select
    Next objSheet
    Set objSheet = Nothing

    ' // assign the Filepath & Filename - you could use a Defined Name or [MyDefinedName].Value2 etc.
    strFile = Sheets("Tables & System").Range("M1").Value2 & _
              Application.PathSeparator & Sheets("Tables & System").Range("M2").Value2

    ' // assign File Format Number
    intFileFormatNum = 50    ' .xlsb

    ' // copy out the Worksheets into a New Workbook
    '    amend this for any other Worksheets that are built for the Red Zone
    Sheets(Array(1, 2, 4, 5)).Copy ' can be "Sheet1", "Sheet2" etc.

    ' copy out the Code from the 'mdlSubroutines' Code Module
    Dim SourceVBProject As VBIDE.VBProject, DestinationVBProject As VBIDE.VBProject
    Set SourceVBProject = ThisWorkbook.VBProject
    Dim NewWb As Workbook
    Set NewWb = ActiveWorkbook
    Set DestinationVBProject = NewWb.VBProject
    Dim SourceModule As VBIDE.CodeModule, DestinationModule As VBIDE.CodeModule
    Set SourceModule = SourceVBProject.VBComponents("mdlSubroutines").CodeModule
    Set DestinationModule = DestinationVBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
    With SourceModule
        DestinationModule.AddFromString .Lines(1, .CountOfLines)
    End With

    '    ' // delete any transported Defined Names matching *RedZone*
    '    '    04.03.2015
    '    Dim nName As Name
    '    For Each nName In ActiveWorkbook.Names
    '      If nName.Name Like "*RedZone*" Then
    '       'MsgBox nName.Name
    '       nName.Delete
    '      End If
    '    Next nName

    ' delete any specific Defined Names
    On Error Resume Next
    For Each n In ActiveWorkbook.Names
        If n.Name = "RZ.BaseUnitOfMeasure" Then n.Delete
        If n.Name = "RZ.Contractual.Targets" Then n.Delete
        If n.Name = "RZ.CustomerPlanningGroups" Then n.Delete
        If n.Name = "RZ.Customers" Then n.Delete
        If n.Name = "RZ.EQB.Conversions" Then n.Delete
    Next n
    On Error GoTo 0

    ' // save the New Workbook
    ActiveWorkbook.SaveAs Filename:=strFile, FileFormat:=intFileFormatNum, CreateBackup:=False
    ActiveWindow.Close
    Application.DisplayAlerts = False

    Sheets("Instructions").Select
    Application.DisplayStatusBar = True
    Application.StatusBar = "Save Report complete..."

End Sub





Looping Worksheets By Array Of Sheet Names Or Code Names

Here are some basic methods to iterate Worksheets by an Array of Sheet Names, by Sheet Names & by Code Names. The last Example allows you to set the Worksheet Object by the Sheet Code Name:

Option Explicit
 
Private Sub LoopWorksheetsbyArrayOfSheetNames()
 
    ' // vars
    Dim Sheet As Worksheet
 
    ' // loop by Worksheet Name i.e. "Sheet1", "foobar" etc.
    '    explicit Workbook reference
    For Each Sheet In ThisWorkbook.Worksheets(Array("Sheet1", "Sheet3"))
 
        Sheet.Activate
 
    Next Sheet
 
    Set Sheet = Nothing
 
End Sub
 
Private Sub LoopWorksheetsbySheetNames()
 
    ' // vars
    Dim Sheet As Worksheet
 
    ' // loop by Worksheet Name i.e. "Sheet1", "foobar" etc.
    '    explicit Workbook reference
    For Each Sheet In ThisWorkbook.Worksheets
 
        Select Case Sheet.Name
 
            Case "Sheet1", "Sheet3"
 
                Sheet.Activate
 
        End Select
 
    Next Sheet
 
    Set Sheet = Nothing
 
End Sub
 
Private Sub LoopWorksheetsbyCodeNames()
 
    ' // vars
    Dim Sheet As Worksheet
 
    ' // loop by Code Name i.e. Sheet1, foobar etc.
    '    explicit Workbook reference
    For Each Sheet In ThisWorkbook.Worksheets
 
        Select Case Sheet.CodeName
 
            Case "Sheet1", "Sheet3"
 
                Sheet.Activate
 
        End Select
 
    Next Sheet
 
    Set Sheet = Nothing
 
 
End Sub
 
Private Sub SetWorksheetObjectNameByCodeName()
 
    ' // vars
    Dim Sheet As Worksheet
 
    ' // set a reference to the Worksheet Object by the Worksheet Code Name i.e. Sheet1 called "foobar"
    Set Sheet = ActiveWorkbook.Sheets(ActiveWorkbook.VBProject.VBComponents("foobar").Properties("Name").Value)
    MsgBox Sheet.Name
 
End Sub



Inserting A New Record ID Into A Column Using The Application.WorksheetFunction

To insert a New Record in a Column you can use the Application.WorksheetFunction. This Code will insert the next available ID using the MAX() Function into Column A on the active Worksheet:

Sub InsertRecord()
 
Dim rngNewRecord As Range

Set rngNewRecord = Range("A1").End(xlDown).Offset(1, 0)
rngNewRecord.Value2 = WorksheetFunction.Max(ActiveCell.EntireColumn) + 1
 
End Sub





Toggle Or Minimize the Ribbon As Opposed To Actually Hiding It

If you are searching for a way to Minimize the Ribbon as opposed to actually hiding it, then use the following Code to Minimize the Ribbon if it is Maximized instead of the SendKeys approach:

Sub MinimizeRibbon()
 If Application.CommandBars.Item("Ribbon").Height > 80 Then Application.CommandBars.ExecuteMso "MinimizeRibbon"
End Sub

Sub ToggleRibbon()
 Application.CommandBars.ExecuteMso "MinimizeRibbon"
End Sub



How To Clear Multiple Cells Or Ranges On a Worksheet or Worksheets all at Once

To clear data in many Cells on a Worksheet you can use Code like this (this example picks up the Worksheet Name from a Defined Name called 'SheetName'). Here is the Clearing Multiple Ranges using single String Cell References.xlsm Workbook and here is the Clearing Ranges on Multiple Worksheets Macro.xlsm Workbook:

Private Sub ClearReportData()
 
    ' vars
    Dim strSheetName As String
    strSheetName = Range("SheetName").Value2
 
    Dim strCells As String
    strCells = "E6:E8, B14:C18, E14:G18, I14:J14, L14:N14, E23:E25, B31:C35, E31:G35, I31:J35, L31:N35, E40:E42, B48:C52, E48:G52, I48:J52, L48:N52"
 
    ' clear the amed Ranges by prefixing the Named Range with the Worksheet Name
    With Worksheets(strSheetName)
        .Range(strCells).ClearContents
    End With
 
End Sub


' and using a Defined Name like Monday_data, Tuesday_data and a Formula for each Range
=Monday!$E$6:$E$8,Monday!$B$14:$C$18,Monday!$E$14:$G$18,Monday!$I$14:$J$18,Monday!$L$14:$N$18,Monday!$E$23:$E$25,Monday!$B$31:$C$35,Monday!$E$31:$G$35,Monday!$I$31:$J$35,Monday!$L$31:$N$35,Monday!$E$40:$E$42,Monday!$B$48:$C$52,Monday!$E$48:$G$52,Monday!$I$48:$J$52,Monday!$L$48:$N$52

    ' we can then use the following to clear many Worksheets (name each Worksheet Monday, Tuesday etc.)
    Private Sub ClearReportData()

    ' vars
    Dim strSheetName As String
    strSheetName = Range("SheetName").Value2

    ' clear the amed Ranges by prefixing the Named Range with the Worksheet Name
    With Worksheets(strSheetName)
     .Range(strSheetName & "_data").ClearContents
    End With

End Sub





Store Keys And Items In The VBA Hidden Namespace

Here is an easy way of storing Keys & their respective Items in the VBA hidden Namespace. The example details storing, displaying and then deleting the Key & Item. I have also included the way to store Values using dummy VBA Variables. This data will persist until the Excel instance is closed:

Sub Example()
 
    ' store the Value for the "Key"
    Application.ExecuteExcel4Macro "SET.NAME(""Key"",""Item1"")"
     
    ' display the stored Value for the "Key"
    MsgBox Application.ExecuteExcel4Macro("Key")
     
    ' delete the "Key" & its respective Value
    Application.ExecuteExcel4Macro "SET.NAME(""Key"")"
 
    ' storing VBA Variables
    Application.ExecuteExcel4Macro "SET.NAME( """ & PivotTableWorksheet & PivotTable & """ , """ & strAddress & """ )"
 
End Sub



Output A Range Of Headers With Bold Formatting Using Array

Here is a useful way to Output a Range of Headers with Bold Formatting using an Array for the Active Worksheet:

Sub AddingHeadersByArray()
 
' add a Header Range from A1:D4, set to Bold & autofit Column widths
With ActiveSheet.Range("A1:D1")
 .Value = Array("Product", "Product Description", "Depot", "Depot Description")
 .Font.Bold = True
 .Cells.EntireColumn.AutoFit
End With
 
End Sub





Run A Macro On Opening An Excel Workbook

Q. How can I automate Code in Excel using VBA?
A. Here are are a couple of methods - if you use both, Method 2 will always fire first, but even closing Excel using Application.Quit will not prevent Method 1 from being executed so pick one or the other
1. Use the Sub auto_open() once in any Code Module:

Sub auto_open()
 MsgBox "foo"
End Sub
 
2. Use the Sub Workbook_Open() once in the ThisWorkbook Code Module:
Private Sub Workbook_Open()
 MsgBox "foobar"
End Sub



Iterate all Shapes in a Group of Shapes for Caller Name, Caller ID, Name, Group Name & Grouped Items

If you want to iterate through a Shapes Grouped Items, add this Code to one of the Shapes (Right-click, Assign Macro). The results will be output to the Immediate Window in the VBA Editor:

Sub IterateShape()

    Dim objShape As Shape
    Dim objSubShape As Shape
    Set objShape = ActiveSheet.Shapes(Application.Caller)
    Debug.Print "Shape ID: " & objShape.ID                                ' caller id
    Debug.Print "Shape Caller Name: " & objShape.Name                     ' caller name, ie. "button"
    Debug.Print "Shape Group Name: " & objShape.ParentGroup.Name          ' group name, ie "burger"
    If objShape.ParentGroup.Type = msoGroup Then
    Set objShape = ActiveSheet.Shapes(objShape.ParentGroup.Name)
      For Each objSubShape In objShape.GroupItems                         ' grouped item, ie "flash"
        Debug.Print "Shape Group Item: " & objSubShape.Name
      Next objSubShape
    End If

End Sub