Kubiszyn.co.uk
VBA

Here are some of my fast, efficient Coding Techniques using Visual Basic for Applications. Where possible I will also include some Short Notation techniques to evaluate Ranges and Cells. Highlight all of the Code within the box boundries using the Mouse and then press CTRL+C to copy to the Clipboard



32 Bit And 64 Bit API Declarations For VBA Developers


Here is a list of common 32 bit & 64 bit 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 hundreds of 64 bit and 32 bit Declare statements for Visual Basic for Applications Win32API_PtrSafe.:


#If VBA7 Then
' 64bit API Declarations
#Else
' 32bit API Declarations
#End If




Core Subroutines & Functions


These are some legacy Subroutines and Functions - you are free to modify this Code
mdlCoreSubroutines.bas




Removing Row Duplicates in a Range or Column


If you have a list of repeated Items and want to remove any duplicates (including/excluding the Header value), you can use the following Code:


' using an OffSet to exclude Headers and the Range must be contiguous (Blanks will stop the process)
Range("A1").CurrentRegion.Offset(1, 0).RemoveDuplicates (Array(1))

' using Short Notation and include/exclude Headers - will cover the Entire Column A
[A:A].RemoveDuplicates Columns:=1, Header:=xlNo
[A:A].RemoveDuplicates Columns:=1, Header:=xlYes

' and further shortened - will cover the Entire Column A and will include the Header
Columns(1).RemoveDuplicates Columns:=1
[A:A].RemoveDuplicates Columns:=1

' Range, notice the use of the Columns Array to specify specific Columns
' also, remember, this will remove duplicates of any Rows that are the same for the first 4 Columns, not duplicates anywhere in the Range
ActiveSheet.Range("A:D").RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes




Replacing Zero or Negative values in a Range, Cells or Defined Name with Blanks


If you have zeros included in a data extract, you can set these to Blank using the following Code - you can use Columns, Range or a Defined Name and Fuzzy searching with the Asterix '*':


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

' fuzzy search for containing zero - will replace 0 and also replace 10, 100, 101 etc.
Columns("A:D").Replace What:="*0*", Replacement:=""

' Columns, default replace negatives with zero (0) - uses a Minus sign, followed by an Asterix
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

' short notation
[A1:D5].Replace What:="0", Replacement:=""

' using With for the Activesheet in the Workbook
' - you can also use Sheets("Sheet1").Cells or Sheets("Sheet1").CurrentRegion etc.
With ThisWorkbook.ActiveSheet.Cells
 .Replace What:="0", Replacement:=""
End With

' using With for Columns
With Columns("A:D").Cells
 .Replace What:="0", Replacement:=""
End With

' Replacing Errors
.Replace What:="#N/A", Replacement:="", LookAt:=xlWhole




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 Examples
Range("AC8:AH24").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)




Removing VBA Password Protection for older Workbooks .XLS Files


If you have a VBA Protected older .XLS File you can use the following steps to Unprotect the VBA Project (use a free HEX Editor ie. google XVI32 download free):


Backup the xls file
Open the file in a HEX editor (XVI32) and locate the DPB=... part
Change the DPB=... string to DPx=...
Open the xls file in Excel
Open the VBA editor (ALT + F11)
Excel discovers an invalid key (DPx) and asks whether you want to continue loading the project (basically ignoring the protection)
Important!  You will be able to overwrite the password, so change it to something you can remember
Save the xls file
Close and reopen the document




Line Breaks and New Lines using VBA


There are many ways to add line breaks in VBA for Strings:


MsgBox "foo" & Chr$(10) & "bar"

MsgBox "foo" & Chr$(13) & "bar"

MsgBox "foo" & vbCr & "bar"

MsgBox "foo" & vbLf & "bar"

MsgBox "foo" & vbNewLine & "bar"




Creating, Joining and Reading Small Arrays


Here are some simple methods of creating, joining and reading small Arrays:


Sub TestArray()
Dim myArray() As Variant
  'create array from list of comma separated strings
  myArray = Array("One", "Two", "Three")
  'display array elements
  MsgBox myArray(0) & vbCr & myArray(1) & vbCr & myArray(2)
  'this also works with numbers as arguments
  myArray = Array(10, 20, 30)
  'display array elements
  MsgBox myArray(0) & vbCr & myArray(1) & vbCr & myArray(2)
End Sub

Sub TestSplitJoin()
Dim myStr As String
Dim myArray() As String

  'string with values, delimited by comma
  myStr = "A1,B2,C3"
  'split string into array of substrings
  myArray = Split(myStr, ",")
  'display array elements
  MsgBox myArray(0) & vbCr & myArray(1) & vbCr & myArray(2)
  'concatenate all elements of array into one string,
  'with " and " connecting them
  myStr = Join(myArray, " and ")
  'display string
  MsgBox myStr
End Sub




Filtering Multiple Excel Tables on Seperate Worksheets


Here is the Code to Filter and align Excel Tables on separate Worksheets - add a Formula to each Worksheet to trigger the Code ie. =A2:


' Workbook_SheetCalculate, Subroutine to link Table Autofilters whenever a Formula is calculated
' this ensures that any Tables within the Workbook are linked by their respective Autofilter Criteria
' features: use Table Filters or Slicers to align your Tables on different Sheets
' caveats: a Formula should be added to all Sheets to force Calculations ie. =A2 (don't use Table Formula!)
'          only 1 Table per Worksheet
'          only shared Table Fields can be aligned (Filtering different Fields will break the alignment)
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
   Dim TableSheet As Worksheet
   Dim DataTable As ListObject
   Dim X As Long
   ' loop all Worksheets and Tables
   On Error Resume Next
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   For Each TableSheet In ActiveWorkbook.Worksheets
      If TableSheet.ListObjects.Count > 0 Then
         For Each DataTable In TableSheet.ListObjects
            If TableSheet.Name <> ActiveSheet.Name Then
               ' set other Tables to the ActiveSheet Table Filter Criteria
               If DataTable.Name <> ActiveSheet.ListObjects(1).Name Then
                  ' clear down other Filters
                  DataTable.AutoFilter.ShowAllData
                  For X = 1 To DataTable.AutoFilter.Filters.Count
                     ' if the Active Table has a Filter
                     If ActiveSheet.ListObjects(1).AutoFilter.Filters(X).On Then
                        ' if the Filter contains an array of values we need to ensure that the array is assigned correctly together with the Operator
                        If TypeName(ActiveSheet.ListObjects(1).AutoFilter.Filters(X).Criteria1) = "Variant()" Then
                           DataTable.Range.AutoFilter Field:=X, Criteria1:=ActiveSheet.ListObjects(1).AutoFilter.Filters(X).Criteria1(), _
                           Operator:=ActiveSheet.ListObjects(1).AutoFilter.Filters(X).Operator
                        Else
                           ' Filter contains only 1 value
                           If ActiveSheet.ListObjects(1).AutoFilter.Filters(X).Criteria2 = vbNullString Then
                              DataTable.Range.AutoFilter Field:=X, Criteria1:=ActiveSheet.ListObjects(1).AutoFilter.Filters(X).Criteria1
                           Else
                              ' Filter contains more than 1 value so add the second Criteria and the Operator
                              DataTable.Range.AutoFilter Field:=X, Criteria1:=ActiveSheet.ListObjects(1).AutoFilter.Filters(X).Criteria1, _
                              Operator:=ActiveSheet.ListObjects(1).AutoFilter.Filters(X).Operator, _
                              Criteria2:=ActiveSheet.ListObjects(1).AutoFilter.Filters(X).Criteria2
                           End If
                        End If
                     End If
                  Next X
               End If
            End If
         Next DataTable
      End If
   Next TableSheet
   On Error GoTo 0
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub




Autofilter Examples


Here are some quick AutoFilter Examples:


' detect if an AutoFilter is on for the ActiveSheet
If ActiveSheet.AutoFilterMode = True Then MsgBox "Autofilter is on"

' getting the AutoFilter Range Address
MsgBox ActiveSheet.AutoFilter.Range.Address

' using the Or
Worksheets("Sheet1").Range("A1").AutoFilter Field:=2, Criteria1:="Bulmers", Operator:=xlOr, Criteria2:="CIDER"

' using the And
Worksheets("Sheet1").Range("A1").AutoFilter Field:=4, Criteria1:=">1", Operator:=xlAnd, Criteria2:=">2"

' handle the AutoFilter if on.  turn off and store the Address
Dim AutoFilterAddress As String
With ActiveSheet
 If .AutoFilterMode = True Then
 AutoFilterAddress = .AutoFilter.Range.Address
 .Range(AutoFilterAddress).AutoFilter
 End If
End With

' check if the First Criteria of an AutoFilter is Filtering
With ActiveSheet
 If .AutoFilterMode = True Then
 With .AutoFilter.Filters(1)
  If .On Then MsgBox "filtering"
 End With
 End If
End With

' check if an AutoFilter is Filtering
With ActiveSheet
 If .AutoFilterMode = True Then
  If .FilterMode = True Then
   MsgBox "filtering"
  End If
 End If
End With

' check if an AutoFilter is Filtering and Unfilter the Filtering (don't remove the AutoFilter)
With ActiveSheet
 If .AutoFilterMode = True Then
  If .FilterMode = True Then
   .ShowAllData
  End If
 End If
End With




Formatting a Pivot Table Values Field


If you have a Pivot Table with lots of Value Fields and want a quick way to Format the values ie. comma, use a '-' for zeros etc. then you can use the following Macro:


Public Sub FormatPivotTable()
  Dim objPivotTable As PivotTable
  Dim objPivotField As PivotField
  For Each objPivotTable In ActiveSheet.PivotTables
    For Each objPivotField In objPivotTable.DataFields
      ' simple whole numbers, comma format
      objPivotField.NumberFormat = "#,##0"
      ' similar to the above but also format zero with wide hyphen
      objPivotField.NumberFormat = "#,##0;-#,##0;""—"""
    Next objPivotField
  Next objPivotTable
End Sub




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. I 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 the last Row in a Range


If you have a Range of data and wish to delete just the last Row, then you can use the Code below (configure as required - this Code finds the last Row from the bottom up and is best used on contiguous Column data):


' in a Code Module, delete the last Row in Column 1 ie. "A"
With Activesheet
 .Cells(Rows.Count, 1).End(xlUp).EntireRow.Delete
end with

' in a Worksheet Code Module, delete the last Row in Column 2 ie. "B"
Me.Cells(Rows.Count, 2).End(xlUp).EntireRow.Delete




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)
' will remove all Blank Rows in the Column with or without a Header Cell
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) 
' this means that you can have a Blank Header or you could start this routine further down the Column ie. Cell "A10" with Blank Cells above
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
On Error GoTo 0

' delete any Rows containing blank Cells in the Active Worksheet for the Used Range
' so for example any disparate values will appear to shift to the top Rows for all of the Columns in the Used Range 
On Error Resume Next
ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0




Opening a Workbook Containing Macros without Running the Macros


If you have a Workbook that runs Code on opening you may not find it easy to actually open the Workbook to examine or edit the Code - here is the Code to allow you to do just that. Simply run the Subroutine and Browse to the File that you want to open without running Macros:


Public Sub OpenWorkbookDisableMacros()
    Dim lngAutomation As MsoAutomationSecurity

    With Application
        lngAutomation = .AutomationSecurity
        .AutomationSecurity = msoAutomationSecurityForceDisable
        With .FileDialog(msoFileDialogOpen)
            .Show
            .Execute
        End With
        .AutomationSecurity = lngAutomation
    End With

End Sub




Adding the Current PC User, Username or Account Name into a Filepath


Sometimes you may need to use the person who is currently logged in as part of a Filepath to a Folder on a local or remote drive when using VBA. This Code allows you to do that by using a generic Machine variable:


' an example of incorpurating the current user of a PC into the Pathname to a Folder on a local or remote drive
' the part you need is 'Environ$("Username")'
"C:\Users\" & Environ$("Username") & "\Company Name\Company Folder\Reports (Monday)\" & Filename




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
MsgBox [A1048576].End(xlUp).Row

' 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 some methods to get the last Column in a variety of different ways:


' Find last Column or Row with some Text in it but allow a Formula to be parsed as Blank
MsgBox Rows("1:1").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Column
MsgBox Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row

' Pickup an Array until first Blank Row or Last Blank Row (omitting the Header Cell).  allows empty Cells in the data
Dim Concat As Variant
With Sheet1
 Concat = Application.Transpose(.Range(.Columns(1).End(xlDown), .Columns(1).End(xlUp)))
 Concat = Application.Transpose(.Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Cells)
End With

' Find the last Row in a Sheet from the bottom up - allows empty Cells in the data 
Dim LastRow As Long
With Sheet1
 LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

' find last Column in Row 1, working backwards
' for example if some value was in Cell "B1" then the Code would return 2 for Column "B"
' however if a value was also in Cell "D1" then the Code would return 4 for Column "D" the last Column in Row 1
MsgBox Cells(1, Columns.Count).End(xlToLeft).Column

' find last Column in contiguous Range from a Range Cell
' for example if there were values in Cells "A1:A3" then the Code would return 3
MsgBox Range("A1").End(xlToRight).Column

' find last Column in Current Region from a Range Cell
' Current Region may be a disparate values et of Rows and Columns that are contiguous
MsgBox Cells(Range("A1").CurrentRegion.Rows.Count, Range("A1").CurrentRegion.Columns.Count).Column
'MsgBox Cells([A1].CurrentRegion.Rows.Count, [A1].CurrentRegion.Columns.Count).Column

' or shorter like this
MsgBox Range("A1").CurrentRegion.Columns.Count
'MsgBox [A1].CurrentRegion.Columns.Count

' find the first or 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(Cells.Find(What:="*", SearchDirection:=xlNext).Column).Address(, False), ":")(1)
MsgBox Split(Columns(Sheets("Sheet1").Cells.Find(What:="*", SearchDirection:=xlPrevious).Column).Address(, False), ":")(1)
MsgBox Split(Columns(Sheets("Sheet1").Cells.Find(What:="*", SearchDirection:=xlNext).Column).Address(, False), ":")(1)

' find the last Column on the Sheet as an Integer ie. 2 for Column "B"
MsgBox Cells.Find(What:="*", SearchDirection:=xlPrevious).Column

' find the last Column on the ActiveSheet and convert it to a Letter ie. "B"
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)




Finding the Last Row


Here are some methods to get the last Row in a variety of different ways:


' finding the last Row on an entire Sheet
Dim LastRow As Long
LastRow = Cells.Find(What:="*", After:=Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row

' finding the last Row on a specific Sheet using the Me. Sheet Object - add to a Worksheet Code Module
Dim LastRow As Long
With Me
 LastRow = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
End With




Refreshing Pivot Tables


To Refresh all Pivot Tables (includes data connections, Tables etc.):


ActiveWorkbook.RefreshAll




Evaluate (Concatenate 1)


Instantly Concatenate and Output 2 Columns of Data (specific Range, can be built using a String). Load the Concatenated Ranges into a Variant Array and then output the Array:


Public Sub ConcatenateRanges1()
 Dim ConcatenateRange As Variant
 Dim EvaluateTranspose As String
 EvaluateTranspose = "TRANSPOSE(A1:A1359)&""|""&TRANSPOSE(B1:B1359)"
 ConcatenateRange = Application.Transpose(Evaluate(EvaluateTranspose))
 Range("G1:G1359") = ConcatenateRange
End Sub




Evaluate (Concatenate 2)


Instantly Concatenate and Output 2 Columns of Data (full Columns). Load the Concatenated Ranges into a Variant Array and then output the Array:


Public Sub ConcatenateRanges1()
 Dim ConcatenateRange As Variant
 Dim EvaluateTranspose As String
 EvaluateTranspose = "TRANSPOSE(A:A)&""|""&TRANSPOSE(B:B)"
 ConcatenateRange = Application.Transpose(Evaluate(EvaluateTranspose))
 Range("G:G") = ConcatenateRange
End Sub




Evaluate - some simple evaluate examples


The use of '+' apparently can speed up these routines and actually the Equal '=' is not required. The second example below will instantly Concatenate Ranges A and B with a pipe. It will then return all Matched Row numbers from Range C into a Variant Array (Please Note: I used the Sheet Name 'Data' for these examples):


Dim v As Variant
v = Evaluate("+TRANSPOSE(MATCH(Data!A2:A34 & ""|"" & Data!B2:B34,Data!C2:C34,0))")
v = Evaluate("=INDEX(MATCH(Data!A2:A34 & ""|"" & Data!B2:B34,Data!C2:C34,0),0,1)")
v = Evaluate("+IFERROR(TRANSPOSE(MATCH(Data!A2:A34 & ""|"" & Data!B2:B34,Data!C2:C34,0)),0)")
v = Evaluate("+IFERROR(TRANSPOSE(MATCH(Data!A2:A34 & ""|"" & Data!B2:B34,Data!C2:C34,0)),"""")")

' use of Evaluate without the Sheet Name
v = Evaluate("=INDEX(MATCH(A1:A3 & ""|"" & B1:B3,C1:C3,0),0,1)")

' added IfError to wrap up errors into either double quotes or zeros
v = Evaluate("=IFERROR(INDEX(MATCH(A1:A3 & ""|"" & B1:B3,C1:C3,0),0,1),"""")")
v = Evaluate("=IFERROR(INDEX(MATCH(A1:A3 & ""|"" & B1:B3,C1:C3,0),0,1),0)")




Outputting the first Subscript only from 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 AnArray() As Variant
ReDim AnArray(1 To 5, 1) ' slot 1 for the second Subscript

' store contents in first Subscript
AnArray(1, 0) = "foo"
AnArray(2, 0) = "bar"
' and one in the second Subscript
AnArray(1, 1) = "foobar"


' output to a Worksheet in one go and the contents of the first Subscript will be written
Range("A2:A" & 5) = AnArray
' or output all the elements for both Subscripts
Range("A2:B" & 5) = AnArray




Check if a Worksheet Exists and is Legal


You can use a combination of these to validate a Worksheet or you could wrap it all up in a Function:


' local constants
Private Const NotesSheetName As String = "Sheet3"
Private Const NotesSheetIndexCell As String = "A1"

' check for valid character length
If Len(NotesSheetName) = 0 Or Len(NotesSheetName) > 31 Then MsgBox "The Notes Sheet Name length is invalid" & vbLf & vbLf & "Please check the Editable Constant for the 'NotesSheetName' in the Setup Section at the top of the Worksheet Code Module", vbExclamation, ThisWorkbook.Name & ", Refresh Pivot Table"

' check for illegal characters
Dim X As Long
Dim InvalidCharacters As Variant
InvalidCharacters = Array("/", "\", "[", "]", "*", "?", ":")
For X = LBound(InvalidCharacters) To UBound(InvalidCharacters)
  If InStr(NotesSheetName, (InvalidCharacters(X))) > 0 Then MsgBox "The Notes Sheet Name contains illegal characters" & vbLf & vbLf & "Please check the Editable Constant for the 'NotesSheetName' in the Setup Section at the top of the Worksheet Code Module", vbExclamation, ThisWorkbook.Name & ", Refresh Pivot Table": GoTo Catch
Next X

' check if the Worksheet exists in the Workbook
If Target.Parent.Evaluate("ISREF('" & NotesSheetName & "'!A1)") = False Then MsgBox "The Notes Sheet Name does not exist or has been modified/renamed" & vbLf & vbLf & "Please check the Editable Constants for the 'NotesSheetName' in the Setup Section at the top of the Worksheet Code Module", vbExclamation, ThisWorkbook.Name & ", Refresh Pivot Table"

' check if the Worksheet Cell or Range to be used exists in the Workbook
If Target.Parent.Evaluate("ISREF('" & NotesSheetName & "'!" & NotesSheetIndexCell & ")") = False Then MsgBox "The Notes Sheet Index Cell is not valid" & vbLf & vbLf & "Please check the Editable Constants for the 'NotesSheetIndexCell' in the Setup Section at the top of the Worksheet Code Module", vbExclamation, ThisWorkbook.Name & ", Refresh Pivot Table"




Adding Document Properties / File Attributes


You can add Document Properties like Title, Subject, Date/Time Stamp etc. using VBA like this - you can also reference a Workbook Variable or use 'ActiveWorkbook' when creating new Workbooks to Save or Email instead of using ThisWorkbook:


ThisWorkbook.BuiltinDocumentProperties("title").Value = "SKU Management Report"
ThisWorkbook.BuiltinDocumentProperties("subject").Value = "A Weekly SKU Report"
ThisWorkbook.BuiltinDocumentProperties("last author").Value = "Mark Kubiszyn"
ThisWorkbook.BuiltinDocumentProperties("comments").Value = "This is a comment..."
ThisWorkbook.BuiltinDocumentProperties("content status").Value = "Complete"
ThisWorkbook.BuiltinDocumentProperties("category").Value = "Supply Chain"
ThisWorkbook.BuiltinDocumentProperties("creation date").Value = Now()
ThisWorkbook.BuiltinDocumentProperties("last save time").Value = Now()
 



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 dummy data above into a Variant Array from a Worksheet
vntData = Range("A2:B5")

' iterate a dummy data array containing 2 Columns 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)
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" will equal 3 (4th position 0,1,2,3)
' use Option Base 1 if you want the Index to start at 1 ie. "C" to equal 3 (1,2,3,4)
Dim vntArray
vntArray = Array("a", "b", "c", "D")
MsgBox "Item: " & vntArray(3) & ", Item Index: " & Application.WorksheetFunction.Match("c", vntArray, 0)

' count the number of Cells in a Range that are not empty in a Column
MsgBox Cells(Application.WorksheetFunction.CountA(Columns(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
 



Copy a Range to the Clipboard as a Picture


To Copy a Range to the Clipboard as a Picture use the folllowing Code:


Public Sub CopyRangeAsPictureToClipboard()
 Dim CopyRange As Variant
 Set CopyRange = Range("A1:B5")
 CopyRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End Sub




QuickSort Array Subroutine


Need a QuickSort Subroutine to Sort a Variant Array in Memory Ascending? Use the Code below with a Call like this:

QuickSort UIDArray, 0, UBound(UIDArray)


'-¬ QuickSort, sorts an Array by reference
Public Sub QuickSort(ByRef ArrayToSort As Variant, ByVal ArrayLowBound As Long, ByVal ArrayHighBound As Long)
   Dim PivotPoint As Variant
   Dim TemporarySwap As Variant
   Dim TemporaryLowBound As Long
   Dim TemporaryHighBound As Long
   TemporaryLowBound = ArrayLowBound
   TemporaryHighBound = ArrayHighBound
   PivotPoint = ArrayToSort((ArrayLowBound + ArrayHighBound) \ 2)
   While (TemporaryLowBound <= TemporaryHighBound)
      While (ArrayToSort(TemporaryLowBound) < PivotPoint And TemporaryLowBound < ArrayHighBound)
         TemporaryLowBound = TemporaryLowBound + 1
      Wend
      While (PivotPoint < ArrayToSort(TemporaryHighBound) And TemporaryHighBound > ArrayLowBound)
         TemporaryHighBound = TemporaryHighBound - 1
      Wend
      If (TemporaryLowBound <= TemporaryHighBound) Then
         TemporarySwap = ArrayToSort(TemporaryLowBound)
         ArrayToSort(TemporaryLowBound) = ArrayToSort(TemporaryHighBound)
         ArrayToSort(TemporaryHighBound) = TemporarySwap
         TemporaryLowBound = TemporaryLowBound + 1
         TemporaryHighBound = TemporaryHighBound - 1
      End If
   Wend
   If (ArrayLowBound < TemporaryHighBound) Then QuickSort ArrayToSort, ArrayLowBound, TemporaryHighBound
   If (TemporaryLowBound < ArrayHighBound) Then QuickSort ArrayToSort, TemporaryLowBound, ArrayHighBound
End Sub




Bubble Sort Worksheet Array Function


Need a Bubble Sort to sort a list Alphabetically. You can use this Array Worksheet Function by www.dumies.com. If you need it to display Horizontally you can use =TRANSPOSE(Sorted(A2:A6)). When entering the =Sorted(A2:A6) select the entire Range that you want this list to be sorted into, click into the Formula Bar and then Type the Formula. Press CTRL+SHIFT+ENTER and it will update accordingly:


' https://www.dummies.com/software/microsoft-office/excel/working-with-vba-functions-that-return-an-array-in-excel-2016/
Function Sorted(Rng As Range)
  Dim SortedData() As Variant
  Dim Cell As Range
  Dim Temp As Variant, i As Long, j As Long
  Dim NonEmpty As Long
  For Each Cell In Rng
    If Not IsEmpty(Cell) Then
      NonEmpty = NonEmpty + 1
      ReDim Preserve SortedData(1 To NonEmpty)
      SortedData(NonEmpty) = Cell.Value
    End If
  Next Cell
  For i = 1 To NonEmpty
    For j = i + 1 To NonEmpty
      If SortedData(i) > SortedData(j) Then
        Temp = SortedData(j)
        SortedData(j) = SortedData(i)
        SortedData(i) = Temp
      End If
    Next j
  Next i
  Sorted = Application.Transpose(SortedData)
End Function




Delete Elements in a Variant Array Function


This returns ByRef an adjusted Array and the Size of the new Array where Elements matching the Criteria have been removed. requires Option Base 1. Use like this to delete any Elements containing vbNullString or Blank:

NumberOfHeaders = DeleteElements(HeaderSortOrder, vbNullString)


'-¬ returns ByRef an adjusted Array and the Size of the new Array where Elements matching the Criteria have been removed
'   requires Option Base 1
Public Function DeleteElements(ByRef Jagged As Variant, ByVal Criteria As String) As Long
 Dim Index As Long
 Dim ReIndex As Long
 ReIndex = 1
 ReDim TemporaryArray(ReIndex)
  For Index = 1 To UBound(Jagged)
   If CStr(Jagged(Index)) <> Criteria Then
    ReDim Preserve TemporaryArray(ReIndex)
    TemporaryArray(ReIndex) = Jagged(Index)
    ReIndex = ReIndex + 1
   End If
  Next Index
 ReDim Jagged(UBound(TemporaryArray))
 Jagged = TemporaryArray
 DeleteElements = UBound(TemporaryArray) 'ReIndex - 1
 ' cleanup
 Index = 0
 ReIndex = 0
 Erase TemporaryArray
End Function




Quick method to Sort Data even if you want the first Row to remain Unsorted


Use the folllowing Code with any of the example methods. Please note this routine will Sort the second Row and all of the data due to the addition of '.Offset(2, 0)' and Header 'xlNo'. To do a normal Sort from the first Row after the Headers remove the '.Offset(2, 0)' and set Headers to 'xlYes'. Another point is that Defined Name can be a Cell Address ie. SortData System.Range(ThemesSortAddress), 1, xlAscending where ThemesSortAddress = "A10":


'    Example
'    Call SortData([List], 1, xlAscending)
'
'    Parameters
'    MyDefinedName := [List] or Range("List")
'    MyColumn := 1, or "A" or "a:a" (if using "A" this will mean the number 1, the first Column
'    in the Defined Names CurrentRegion not Column A)
'    MySortDirection := xlAscending or xlDescending
'    SortData System.Range(ThemesSortAddress), 1, xlAscending

Public Sub SortData(ByVal MyDefinedName As Range, _
ByVal MyColumn As Variant, _
ByVal MySortDirection As XlSortOrder)

   ' // defines a String Variable used to store the Sort Range built from a single Defined Name
   Dim RangeToSort As String
   RangeToSort = MyDefinedName.Columns(MyColumn).Address & _
   ":" & _
   MyDefinedName.Columns(MyColumn).End(xlDown).Address

   ' // setup the Sort
   With MyDefinedName.Worksheet
      .Sort.SortFields.Clear
      .Sort.SortFields.Add2 Key:=MyDefinedName.Worksheet.Range(RangeToSort), _
      SortOn:=xlSortOnValues, _
      Order:=MySortDirection, _
      DataOption:=xlSortNormal

      ' // apply the Sort
      With MyDefinedName.Worksheet.Sort
         .SetRange MyDefinedName.CurrentRegion.Offset(2, 0)
         .Header = xlNo                          'xlYes
         .SortMethod = xlPinYin
         ' // catch any errors, sort will silently fail
         On Error Resume Next
         .Apply
         On Error GoTo 0
      End With
   End With

End Sub




Get Data from a Closed Workbook as Special Values very Fast


Here is an actual Example of using this technique in a Macro I have written for my Holiday Planner Software - HP_Updater_v1.xlsm

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




Error handling


Here is an Error Handling Routine for a Code Module Subroutine or Function posted here:
https://codereview.stackexchange.com/questions/143895/making-repeated-adodb-queries-from-excel-sql-server


Public Sub DoSomething()
    On Error GoTo CleanFail

    ' code

CleanExit:
    ' cleanup code
    Exit Sub
CleanFail:
    ' error handling/recovering code
    Resume CleanExit
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). This Code makes the assumption that at least 2 Email Addresses are maintained:


' without spacing, result = mark@foo.com;Tina@bar.net;Paul@foobar.co.uk
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), ";")

' spaced result = mark@foo.com; Tina@bar.net; Paul@foobar.co.uk
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 are my methods 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"";"

' or use this for a Named Range (Defined Name) where Report is the name of your Worksheet and [BS.ReportOutput] is the Named Range
Dim lngLastRow As Long
lngLastRow = Report.Cells(Report.Rows.Count, [BS.ReportOutput].Columns(1).Column).End(xlUp).Row
'lngLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, [BS.ReportOutput].Columns(1).Column).End(xlUp).Row

' a dymamic Named Range example that Formats a Range that is 10 Columns Offset for the number of Rows down as Marlett Font
Dim lngLastRow As Long
Dim ReportOutputRow As Long
Const ColumnToFormat As Long = 10
ReportOutputRow = [BS.ReportOutput].Row
lngLastRow = Report.Cells(Report.Rows.Count, [BS.ReportOutput].Columns(1).Column).End(xlUp).Row
If lngLastRow > ReportOutputRow Then
 Report.Range([BS.ReportOutput].Offset(0, ColumnToFormat).Resize(lngLastRow - ReportOutputRow + 1, 1).Address).Font.Name = "Marlett"
End If




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):


' this Code does not continually try to delete *CASK*
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
' will attempt recursive deletion
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
' will attempt recursive deletion
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
' will attempt recursive deletion
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 (Range maintained for this Example is "I6:KXXXX" with any Criteria stored in the Range "A1:A3"):


' 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




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):


' Method 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."

' now 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



' Method 2. 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




Date & Time Functions


Some useful Date & Time Functions - Format is like the Worksheet Text Function equivalent:


' 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")

' will display 7 Dec '19 (assuming the Date was the 7th December 2019 or Date Serial: 43806, 07/12/2019)
MsgBox Format(Now(), "d mmm 'yy")




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:


' 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)

' return Column Letter for a specific hard-coded Column
MsgBox Split(Columns(16384).Address(, False), ":")(1)

' Short Notation
MsgBox Split([A1].Address, "$")(1)

' 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)

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

' a Function that returns the Column Letter for any Column Number
Dim ColumnLetter As String
ColumnLetter = GetColumnLetter(1)
MsgBox ColumnLetter
	
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 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 CellAddress As String = "H7"
' or... Const CellAddress As String = "$H$7"
Dim CellAddress As String
CellAddress = "H7"

' output the actual Cell Address
MsgBox Range(CellAddress).Address

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

' output the Next Column Letter using the Column Offset of 1 
MsgBox Split(Range(CellAddress).Offset(0, 1).Address(1, 0), "$")(0)




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)
    [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)
    [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)
    ThisWorkbook.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
[LastChanges].Value2 = "last changes applied: " & Format(Now(), "dd/mm/yyyy hh:mm:ss")
ThisWorkbook.Sheets("Sheet1").Range("A1").Value2 = "last changes applied: " & Format(Now(), "dd/mm/yyyy hh:mm:ss")




Use Regular Expressions (RegEx) to Match a Key & return the Item from a Large Delimited String of Key/Items


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 Including Different Methods of Storing the Data


There are so many ways to pick up data into Variant Arrays. Here are a few different ones:


' pick up contiguous Header Range from A1 to the end of the Column Range, Data(1,1), Data(1,2) etc.
Dim Data As Variant
Data = Range(Range("A1"), Range("A1").End(xlToRight))

' or use Transpose for Data(1)->Data(1,1), Data(2)->Data(1,2) etc.
Data = Application.Transpose(Range(Range("A1"), Range("A1").End(xlToRight)))

' and again for Data(1), Data(2) etc.
Data = Application.Transpose(Application.Transpose(Range(Range("A1"), Range("A1").End(xlToRight))))



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

' and again, but split each Column of Data into its own slot ie. Data(1) = "A", Data(2) = "B"
Dim Data As Variant
Data = Application.Transpose(Range(Range("A1:C" & Range("A1").End(xlDown).Row).Address).Cells)



' picking up a 2 Column list of Suppliers by finding the Header 'Supplier Report List' on a Worksheet called 'Sheet1'
' the first Offset is used to omit the actual Header
' 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
Dim Suppliers As Variant
Suppliers = Sheets("Sheet1").Range(Sheets("Sheet1").Cells.Find("Supplier Report List", , xlValues, xlWhole, xlByRows, xlNext, True).Offset(1), _
 Sheets("Sheet1").Cells.Find("Supplier Report List", , xlValues, xlWhole, xlByRows, xlNext, True).Offset(1, 1).End(xlDown))




>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 highlight the current section that has focus
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 to Avoid Using an 'If' Test


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':


' this Code will Format a value of Blank or any number ie. 15 = '15.000', Blank or 0 = '0.000'
MsgBox Format(Range("A1").Value2 + 0, "###0.000")

' I used Format(vntDHLFileOUT(lngY, intX) + 0, "###0.000") in my Code to avoid using a test on the Array values




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 CellReference As String
Dim SelectedRange As Range
Dim NumberOfColumns As Integer
Dim NumberOfRows As Long
    
CellReference = "A1"
NumberOfColumns = 6
NumberOfRows = 10
Set SelectedRange = ActiveSheet.Range(CellReference, Range(Left(Cells(1, Int(NumberOfColumns + Range(CellReference).Column - 1)).Address(1, 0), _
                InStr(1, Cells(1, Int(NumberOfColumns + Range(CellReference).Column)).Address(1, 0), "$") - 1) & Range(CellReference).Row + NumberOfRows - 1)).Cells
    
If Not SelectedRange Is Nothing Then SelectedRange.Select

Here is an alternative Function and an Example Subroutine to do the same thing:


Public Sub BuildRangeExample()
  
 Dim r As Range
 Set r = BuildRange("A1", 2, 6)
 If Not r Is Nothing Then r.Select
   
End Sub
 
' BuildRange() Function, sets & returns a Range Object given:
' a start Cell ie. "D4"
' number of Columns ie. 6
' number of Rows ie. 4
Public Function BuildRange(ByVal start As String, _
                           ByVal cols As Integer, _
                           ByVal rows As Long) As Range
Set BuildRange = Range(start, Range(Left(Cells(1, Int(cols + Range(start).Column - 1)).Address(1, 0), _
 InStr(1, Cells(1, Int(cols + Range(start).Column)).Address(1, 0), "$") - 1) & Range(start).Row + rows - 1)).Cells
End Function




sets a Replacement Format and then applies it to the Text 'Result' in Column "B"


Here is the Code to set and then apply a Cell Format wherever the Text 'Result' is found in a Worksheet Column "B":


Sub ApplyResultRowFormat()

    With Application.ReplaceFormat
        .Clear
        With .Interior
            .ThemeColor = xlThemeColorAccent2
        End With
    End With

    Columns(2).Replace What:="Result", Replacement:="Result", LookAt:=xlWhole, _
                       SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
                       ReplaceFormat:=True

End Sub




Build and Select a Range from a Cell Address and an XY Co-ordinate


Here is the Code to Build and Select a Range from a Cell Address "A1" and an XY Co-ordinate, X = 4, Y = 10 ie. Range = "A1:D10":


Sub BuildRangeFromCellAndXY()

    ' build and select a Range X Columns by Y Rows from a Start Cell "A1"
    Dim SelectedRange As Range, Start As String, X As Integer, Y As Long
    Start = "A1": X = 4: Y = 10
    Set SelectedRange = ActiveSheet.Range(Start, Range(Left(Cells(1, Int(X + Range(Start).Column - 1)).Address(1, 0), _
                                           InStr(1, Cells(1, Int(X + Range(Start).Column)).Address(1, 0), "$") - 1) & Range("A1").Row + Y - 1)).Cells
    SelectedRange.Select

End Sub




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 MatchString As Variant
Dim FindRow As Long
' can use "*Hi there*"  & Chr(34)
MatchString = Chr(34) & "Hi there, my name is Mark" & Chr(34)

On Error Resume Next
FindRow = Evaluate("=MATCH( " & MatchString & ",A:A,0)")
If Err.Number <> 13 Then MsgBox "Found at Row: " & FindRow: Range("A" & FindRow).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):


' Data should be in "A1:C10" for this example and we will swap the Column order on output
' the Code will pull all Data for the Current Region up until the last Row
Sub PickuUpDataSwapColumnOrder()
    Dim Data As Variant

    With Sheet1.Cells(1).CurrentRegion
        Data = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), Array(3, 1, 2))
    End With
    Sheet2.Range("A1").Resize(UBound(Data), 3) = Data
End Sub

Here is the Code to filter the data in Column "A" by testing if Column "B" is less than 10 into Column "C" - requires values in "A1:C10":


Sub MatchAndFilterData()

    Dim Data As Variant
    With Range("a1", Range("a" & Rows.Count).End(xlUp))
        Data = 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(Data) + 1).Value = Application.Transpose(Data)
    End With
    
End Sub

Here are some Evaluate Array examples by Aaron Blood:


Sub Arrays()
     
    Dim xArray() As Variant
    Dim Y As String
     
    ' 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 for a Filtered Range or Filtered Table


I like to display what is AutoFiltered as Text in a Cell. I already have a Function in my mdlCoreSubroutines.bas but wanted one a bit better so I came up with 3 Functions. The first one Displays what is AutoFiltered for Criteria1 or displays the Text '[Mult.]' if more than one Criteria is Selected. The second one displays both Criteria1 and Criteria2 plus the Text '[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 - choose 1 of these for your project). I use the third one in my SKU Management Report at work 'will detail what is included in an AutoFilter showing 2 Criteria in a Filter and multiple Criteria as [Mult.]' called 'AutoFilteredHeaders()':

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

' and for a Filtered Table for Headers at $I$6:$K$6
=@AutoFilteredHeaders($I$6:$K$6) or =AutoFilteredHeaders($I$6:$K$6)

' VBA Code
Public Function AutoFilteredHeaders(ByVal Header As Range) As String
   On Error GoTo Catch
   Dim Y As Long
   Dim Criteria As String
   Dim Temp As String
   Dim Criteria1 As Boolean
   Dim Criteria2 As Boolean
   Dim LO As ListObject
   Application.Volatile
   Set LO = Sheet1.ListObjects(1)
   With LO.AutoFilter
      For Y = 1 To .Filters.Count
         With .Filters(Y)
            Criteria1 = True
            Criteria2 = True
            On Error Resume Next
            Temp = .Criteria1
            If Err.Number = 1004 Then Criteria1 = False
            Err.Clear
            Temp = .Criteria2
            If Err.Number = 1004 Then Criteria2 = False
            Err.Clear
            If Not Criteria1 And Not Criteria2 Then
               ' do nothing
            End If
            On Error GoTo Catch
            If Criteria1 And Not Criteria2 Then
               On Error Resume Next
               Temp = .Criteria1
               If Err.Number = 13 Then
                  Criteria = Criteria & Header.Cells(1, Y) & "[mult.], "
               Else
                  Criteria = Criteria & Header.Cells(1, Y) & .Criteria1 & ", "
               End If
               Err.Clear
            End If
            On Error GoTo Catch
            If Criteria1 And Criteria2 Then
               Criteria = Criteria & Header.Cells(1, Y) & " [" & .Criteria1 & ", " & .Criteria2 & "], "
            End If
         End With
      Next Y
   End With
 
   AutoFilteredHeaders = Mid$(Criteria, 1, Len(Criteria) - 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




Selecting Multiple Worksheets


You can Select multiple Workhseets using the Array() Function:


' by the number given to the Sheet in the order that it is displayed in the Workbook
Sheets(Array(1, 2)).Select

' by refering to the Sheet Name
Sheets(Array("Sheet1", "Sheet2")).Select




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 which is my personal preference:


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 - just add the Header Index in Cell "A1":


Sub InsertRecord()
 
Dim NewRecord As Range

If Range("A2").Value2 = vbNullString Then
 Range("A2").Value2 = 1
Else
 Set NewRecord = Range("A1").End(xlDown).Offset(1, 0)
 NewRecord.Value2 = WorksheetFunction.Max(Range("A1").EntireColumn) + 1
End If

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:


' Minimize if not Minimized
Sub MinimizeRibbon()
 If Application.CommandBars.Item("Ribbon").Height > 80 Then Application.CommandBars.ExecuteMso "MinimizeRibbon"
End Sub

' toggle between Minimize and Maximize
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 Named 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




Password Worksheet Cracker for Excel 2013 & 2016


Here is an updated version of the Password Sheet Cracker for Excel 2013 and Excel 2016. Add the Code to Code Module, Save the File. Switch to the Workbook to Unprotect and Run the Macro below PasswordBreaker:


Sub PasswordBreaker()
   'Breaks worksheet password protection.  I do not condone the use of this Code!
   Dim i As Integer, j As Integer, k As Integer
   Dim l As Integer, m As Integer, n As Integer
   Dim i1 As Integer, i2 As Integer, i3 As Integer
   Dim i4 As Integer, i5 As Integer, i6 As Integer
   On Error Resume Next
   For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
            For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
                     For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
                              For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
                                       Debug.Print Chr(i) & Chr(j) & Chr(k) _
                                       & Chr(l) & Chr(m) & Chr(i1) _
                                       & Chr(i2) & Chr(i3) & Chr(i4) _
                                       & Chr(i5) & Chr(i6) & Chr(n)
                                       DoEvents
                                       ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
                                       Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
                                       Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                                       If ActiveSheet.ProtectContents = False Then
                                          MsgBox "One usable password is " & Chr(i) & Chr(j) & _
                                          Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
                                          Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                                          Exit Sub
                                       End If
                                    Next: Next: Next: Next: Next: Next
                  Next: Next: Next: Next: Next: Next
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 best to just pick one - I usually opt for the second one, the Workbook_Open()


' 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




Running a Dummy Task


Q. How can I run a dummy Task in Excel using VBA?

A. Here is the Code to do just that



' Call using
DummyTask 4000


'-¬ DummyTask, runs a dummy task
Private Sub DummyTask(ByVal TaskLength As Long)
   Dim Start As Date
   Dim Running As Long
   Start = Now()
   For Running = 1 To TaskLength
      Application.StatusBar = "Running Dummy Task Loop: " & Running & " Elapsed Time: " & _
      Format$(Now() - Start, "ss")
      DoEvents
   Next Running
   Application.StatusBar = Empty
   Running = 0
   Start = 0
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




Using an R1C1 Locking Formula in VBA


Here is an example of how to implement R1C1 Lock Formula in VBA for an Excel Formula. Locking Formula when using R1C1 (normally used after recording a Macro to do something in Excel) can be a little tricky especially understanding when it is absolute or relative and then trying to adjust the Code to Lock a Row or a Column when your Code is trying to Copy & Paste or just Copy down the Formula. here is the R1C1 Lock Formula.xlsm Workbook:


Sub UnlockedR1C1()

    Range("C3").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],RC[2]:R[2]C[3],2,0)"
    
End Sub

Sub LockedR1C1()

    Range("C3").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],R2C5:R4C[3],2,0)"
     
End Sub




Print a Range to PDF File


Here is the Code to print a Range to a PDF File:


Sheets("Year Calendar").Range("A1:AN18").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
  "C:\Users\mark\Desktop\Book1.pdf"

' Optional Parameters
Quality:=xlQualityStandard
IncludeDocProperties:=True
IgnorePrintAreas:=False
OpenAfterPublish:=True




Colour Conversion Functions


Here are 2 Functions to convert a Long to RGB Format as a String ie. "RGB(51, 51, 51)":


' LongToRGB, returns a String containing the 3 separate Colours of a Long
' MsgBox LongToRGB(3355443)
Private Function LongToRGB(ByVal Colour As Long) As String
    Dim R As Long
    Dim G As Long
    Dim B As Long
    R = (Colour Mod 256)
    G = (Colour \ 256) Mod 256
    B = (Colour \ 65536) Mod 256
    LongToRGB = "RGB(" & R & "," & G & "," & B & ")"
End Function

'  MakeRGBString, makes a String from a Long Colour.  for example, RGB(0,0,0)
' MakeRGBString(3355443)
Public Function MakeRGBString(ByVal Colour As Long) As String
   MakeRGBString = "RGB(" & Colour - (Colour \ 65536) * 65536 - ((Colour - (Colour \ 65536) * 65536) \ 256) * 256 & ", " & _
   (Colour - (Colour \ 65536) * 65536) \ 256 & ", " & _
   Colour \ 65536 & ")"
End Function

Here are 3 Functions to convert a Long to hexadecimal HTML Format as a String ie. "#333333". The third way is the quickest returning 333333:


' LongToHTML, converts a Long Colour to a HTML String
' MsgBox LongToHTML(3355443)
Public Function LongToHTML(ByVal Colour As Long) As String
   Dim Red As Long
   Dim Green As Long
   Dim Blue As Long
   Red = (Colour Mod 256)
   Green = (Colour \ 256) Mod 256
   Blue = (Colour \ 65536) Mod 256
   LongToHTML = "#" & Application.WorksheetFunction.Dec2Hex(Red, 2) & Application.WorksheetFunction.Dec2Hex(Green, 2) & Application.WorksheetFunction.Dec2Hex(Blue, 2)
End Function

' Dec2HexColor, converts a Decimal Color Code (0 to 16777215) to a hexadecimal HTML color code (#000000 to #FFFFFF)
'  Debug.Print Dec2HexColor(vbMagenta)          'returns: "#FF00FF"
'  Debug.Print Dec2HexColor(12345678)           'returns: "#4E61BC"
'  Debug.Print Dec2HexColor(0)                  'returns: "#000000"
'  Debug.Print Dec2HexColor(RGB(255, 0, 0))     'returns: "#FF0000"
Public Function Dec2HexColor(ByVal decColor As Long) As String
   ' adjusted to pass RubberDuck Code tests by Mark Kubiszyn, 15/04/2019
   Dim Colour As Long
   If decColor > 16777215 Then
      Colour = 16777215
   ElseIf decColor < 0 Then
      Colour = 0
   Else
      Colour = decColor
   End If
   Dec2HexColor = "#" & Right$("00" & Hex$((Colour Mod 256)), 2) & _
   Right$("00" & Hex$((Colour \ 256) Mod 256), 2) & _
   Right$("00" & Hex$(Colour \ 65536), 2)
End Function

Dim HEXColor As String
HEXColor = Right$("0000000" & Hex$(3355443), 6)
MsgBox HEXColor

Here is the Code to Convert from the RGB to the HSL color model:


' RGBToHSL01, Converts from the RGB to the HSL color model
' - more specifically converts Red, Green, and Blue values to Hue, Saturation, and Luminance values
Public Function RGBToHSL(ByVal RGBValue As Long) As HueSaturationLightness
   ' by Branco Medeiros, 1999, branco@apis.com.br
   '   (adapted from Java.awt.Color.java)
   ' adjusted to our definition by Donald, 20011116
   ' adjusted to pass RubberDuck Code tests by Mark Kubiszyn, 15/04/2019
   Dim Minimum As Long
   Dim Maximum As Long
   Dim Delta As Long
   Dim Red As Long
   Dim Green As Long
   Dim Blue As Long
   Dim Temporary As Single

   Red = RGBValue And &HFF
   Green = (RGBValue And &HFF00&) \ &H100&
   Blue = (RGBValue And &HFF0000) \ &H10000
  
   Maximum = IIf(Red > Green, IIf(Red > Blue, Red, Blue), IIf(Green > Blue, Green, Blue))
   Minimum = IIf(Red < Green, IIf(Red < Blue, Red, Blue), IIf(Green < Blue, Green, Blue))
  
   RGBToHSL.Luminance = (Maximum * 100) / 255
  
   If Maximum > 0 Then
      Delta = Maximum - Minimum
      RGBToHSL.Saturation = (Delta / Maximum) * 100
      If Delta > 0 Then
         If Maximum = Red Then
            Temporary = (Green - Blue) / Delta
         ElseIf Maximum = Green Then
            Temporary = 2 + (Blue - Red) / Delta
         Else
            Temporary = 4 + (Red - Green) / Delta
         End If
         RGBToHSL.Hue = Temporary * 60
         If RGBToHSL.Hue < 0 Then
            RGBToHSL.Hue = RGBToHSL.Hue + 360
         End If
      End If
   End If
  
End Function

Here is the Code to return a new Long Colour Code Shade as a Long from a Long Colour Code and Long adjustment Colour Code:


' ColourShade, returns a new Long Colour based upon an initial Long value and an adjustment
Public Function ColourShade(ByVal Colour As Long, ByVal ShadeAdjustment As Long) As Long
   Dim Red As Long
   Dim Green As Long
   Dim Blue As Long
   Dim HEXColor As String
   HEXColor = Right$("000000" & Hex$(Colour), 6)
   Red = WorksheetFunction.Round(CInt("&H" & Right$(HEXColor, 2)) + (ShadeAdjustment * (255 - CInt("&H" & Right$(HEXColor, 2)))) / 15, 0)
   Green = WorksheetFunction.Round(CInt("&H" & Mid$(HEXColor, 3, 2)) + (ShadeAdjustment * (255 - CInt("&H" & Mid$(HEXColor, 3, 2)))) / 15, 0)
   Blue = WorksheetFunction.Round(CInt("&H" & Left$(HEXColor, 2)) + (ShadeAdjustment * (255 - CInt("&H" & Left$(HEXColor, 2)))) / 15, 0)
   ColourShade = Blue * 65536 + Green * 256 + Red
End Function

Here is the Code to determine whether to use a White Font if the Colour is a darker shade or to use a Black Font if the Colour is a lighter shade:


' BlackOrWhiteFont, determine whether to use a White Font
' .Font.Color = BlackOrWhiteFont(HeaderColour, FontColour) where HeaderColour and FontColour are Long values
Public Function BlackOrWhiteFont(ByVal RGB As Long, ByVal FontColour As Long) As Long
   Dim Red As Long
   Dim Green As Long
   Dim Blue As Long
   Red = (RGB And &HFF)
   Green = (RGB And &HFF00&) / 256
   Blue = (RGB And &HFF0000) / 65536
   If Red * 0.3 + Green * 0.59 + Blue * 0.11 > 128 Then BlackOrWhiteFont = FontColour Else BlackOrWhiteFont = vbWhite
End Function




Sigma Code Functions for VBA/Excel Worksheet


Here are 3 Sigma Functions for VBA. One returns the Sigma Code for a String of Integer values ie. 121 = Sigma Code of 4. The second one will return the Sigma Code for Floating Point numbers ie. 12.3 = Sigma Code of 6. The third one will aggregate a String of Comma delimited values into its respective Sigma Code ie. 12,13,14,2 = 5:


' Sigma, Worksheet/VBA Function.  return the Sigma Code for a String of Integers
Public Function Sigma(ByVal N As String) As Long
 Dim I As Long
 Dim C As Long
 While Len(N) <> 1
  I = 1: C = 0
  While I <> Len(N) + 1
   C = C + Mid(N, I, 1): I = I + 1
  Wend
  N = CStr(C)
 Wend
 Sigma = N
End Function

' SigmaRadix, Worksheet/VBA Function.  return the Sigma Code for a String of Floating Point Numbers
' requires SigmaString
Public Function SigmaRadix(ByVal N As String) As Long
 Dim I As Long
 Dim C As Long
 Dim ar: ar = Split(N, ".", , vbTextCompare)
 While Len(ar(0)) <> 1
  I = 1: C = 0
  While I <> Len(ar(0)) + 1
   C = C + Mid(ar(0), I, 1): I = I + 1
  Wend
  ar(0) = CStr(C)
 Wend
 While Len(ar(1)) <> 1
  I = 1: C = 0
  While I <> Len(ar(1)) + 1
   C = C + Mid(ar(1), I, 1): I = I + 1
  Wend
  ar(1) = CStr(C)
 Wend
 SigmaRadix = SigmaString(ar(0) & "," & ar(1))
End Function

' SigmaString, splits and aggregates a String of numbers deriving the Sigma Code for the result
Public Function SigmaString(ByVal N As String) As Long
 Dim I As Long
 Dim C As Long
 Dim S As String
 Dim ar: ar = Split(N, ",", , vbTextCompare)
 For I = 0 To UBound(ar):  S = S + ar(I): Next I
 While Len(S) <> 1
  I = 1: C = 0
  While I <> Len(S) + 1
   C = C + Mid(S, I, 1): I = I + 1
  Wend
  S = CStr(C)
 Wend
 SigmaString = S
End Function




Base Integer/String Conversions


Here are 2 Functions to convert Integers/Strings from one Base into another Base. The first converts small Integers or small Strings from one Base to another ie. 21111201, base 3 into 5473, base 10. The second converts huge Strings from one Base into another ie. "310460164004505603622400541102130363646224613104345026261332366416421445331240036062340356041240623123041301231226532566640040620" Base 7 into 4697085165547666455778961193578674054751365097816639741414581943064418050229216886927397996769537406063869950 in Base 10:


'================================================================================
' Name:         to_base10
' Author:       M P Kubiszyn
' Bugs:         mark@kubiszyn.co.uk, http://www.kubiszyn.co.uk
' Purpose:      will convert a tiny string/integer into base 10
'
' Param1:=      Integer/Small String to convert ie. 1323 or "21111201"
' Param2:=      Integer, the base to convert from ie. 4, or 3
'
' Returns:      an Integer value of the converted Base 10 equivalent
'
' Examples:     #1. 21111201, base 3 := 5473, base 10
'               Dim s As String: s = to_base10("21111201", 3)
'
'               #2. 1323, base 4 := 123, base 10
'               Dim s As String: s = to_base10(1323, 4)
'================================================================================
Public Function to_base10(ByVal x As String, ByVal base As Integer) As Integer
 Dim i, cum As Integer
 For i = Len(x) To 1 Step -1
  cum = cum + Mid(x, i, 1) * base ^ (Len(x) - i)
 Next i
 to_base10 = cum
End Function

'================================================================================
' Name:         to_base10_
' Author:       M P Kubiszyn
' Bugs:         mark@kubiszyn.co.uk, http://www.kubiszyn.co.uk
' Purpose:      will convert huge strings into base 10
'
' Param1:=      String, huge string to convert ie. "310460164004505603622400541102130363646224613104345026261332366416421445331240036062340356041240623123041301231226532566640040620"
' Param2:=      String, the base to convert from ie. 7
'
' Returns:      a Huge String of the converted Base 10 equivalent
'
' Example:      #1. huge 129 digit Base 7 String to 109 digit Base 10 String
'               Dim s As String: s = to_base10_("310460164004505603622400541102130363646224613104345026261332366416421445331240036062340356041240623123041301231226532566640040620", 7)
'               := 4697085165547666455778961193578674054751365097816639741414581943064418050229216886927397996769537406063869950 Base 10
'================================================================================
Public Function to_base10_(ByVal x As String, ByVal base As String) As String
 Dim i, j, k As Integer
 Dim cum As String
 Dim raise_base, calc As String
 k = 1
 raise_base = "1"
  For i = Len(x) To 1 Step -1
   ' raise base exponenially
   calc = "1"
    For j = 1 To k - 1
     raise_base = MY_MX(calc, base): calc = raise_base
    Next j
   k = k + 1
  ' cumulatively add the multiplied digit in x by the exponenial base
  cum = Y_X_BY_Z(cum, MY_MX(Mid(x, i, 1), raise_base), Add)
 Next i
to_base10_ = cum
End Function




Formula to Identify Prime Numbers


Here is my Code to identify Prime numbers - use as VBA or Worksheet Function:


' Author: Mark Kubiszyn
' Name: Prime Number Functions
' Date: Original IsPrime written in 2000 for Borland C++
' re-written for Excel in 2007, published again 2010, modified in 2019
' Please Note: the integer 1 is returned as being Prime

' IsPrime, Worksheet/VBA Function.  returns True or False depending on whether a number is Prime or not
Function IsPrime(ByVal Number As Long) As Boolean
 Dim Divisor As Long
 ' check for single digit prime numbers 2 & 5
 If Number = 2 Or Number = 5 Then IsPrime = True: Exit Function
 ' check for even numbers or multiples of 5
 If Number Mod 2 = 0 Or Number Mod 5 = 0 Then IsPrime = False: Exit Function
 ' check every odd divisor from 3 upwards
 For Divisor = 3 To Number - 2 Step 2
  If Number Mod Divisor = 0 Then
   IsPrime = False
   Exit Function
  End If
 Next Divisor
IsPrime = True
End Function

It follows, then, that one could use Code such as this to identify the Next Prime - use as VBA or Worksheet Function:


Function NextPrime(ByVal Number As Long) As Long
Number = Number + 1
 While Not IsPrime(Number)
  Number = Number + 1
 Wend
NextPrime = Number
End Function




Using File SaveAs in VBA for SharePoint


There is an easy way to Save Files to SharePoint without Uploading using Paths from a Worksheet or a File System Object! Simply obtain a link from your SharePoint site and remove any eroneous parts, so that you have full https:// then /sites/ and then remove the QueryString ending and suffix a forward slash - then you can use FileFormat as normal in VBA:







Count Unique Worksheet Function


This is an extremely fast way to count the number of unique Items in a Column:


' use from a Formula in Excel like this where FilterRange is just a Defined Name linking to a Range or pass the full Range
=IFERROR(CountUnique(FilterRange),"—")
=IFERROR(CountUnique(A1:A10000),"—")

' ## CountUnique, Worksheet Function to count unique items in a Range
Public Function CountUnique(Rng As Range) As String
    On Error Resume Next

    ' // if you set this, then it will fire on event handlers for Cell Selections etc.
    ' Application.Volatile
    Application.ScreenUpdating = False

    ' // vars
    Dim lngY As Long
    Dim vntData As Variant
    Dim dict As Object    'Dictionary

    ' // initialise the Dictionary
    Set dict = CreateObject("Scripting.Dictionary")    'New Dictionary
    'dict.CompareMode = BinaryCompare

    ' // pickup the data
    vntData = Rng

    ' // build the Unique Keys & Items
    For lngY = 1 To UBound(vntData)
        If vntData(lngY, 1) <> "" And Not dict.Exists(vntData(lngY, 1)) Then
            dict.Add vntData(lngY, 1), 1
        End If
    Next lngY

    ' // return the count of unique items
    If dict.Count > 1 Then CountUnique = "Unique Products in this report: " & Format(dict.Count, "#,##0") _
       Else CountUnique = "Unique Product in this report: " & Format(1, "#,##0")

    ' // clean up
    Set dict = Nothing
    Erase vntData

End Function




Highlight Duplicates in either one of 2 Columns when entering Values


These 2 Event Handler Functions will turn any Duplicates entered in Rows in either Column C or Column D where both C and D are duplicates bright Red in Colour, reset back to No Fill or White and / or raise an alert. Add to a Worksheet Code Module, changing the "C:D" to the Columns of your choice , the "C9:D" to the Columns of your choice and the 3 and 4 used with Interior.Color to their respective Column Numbers ie. "C" and "D" = 3 and 4. The RGB value can be changed to any Colour you want. Use the first one to just Colour Duplicates. Use the second one to raise an alert and reset the Fill of allowed values:


' used to identify Duplicates as Red entered within specific Columns in Contiguous Rows
Private Sub Worksheet_Change(ByVal Target As Range)
   ' comment this check out if using Copy & Paste to allow the Event Handler to confirm changes
   If Target.Columns.Count > 1 Then Exit Sub
   If Not Intersect(Target, Range("C:D")) Is Nothing Then
      Application.ScreenUpdating = False
      Dim lngY As Long
      Dim Unique As String
      Dim Data As Variant
      Dim dict As Object
      Dim OffsetRow As Long
      OffsetRow = Target.CurrentRegion.Cells(2, 1).Row
      Set dict = CreateObject("Scripting.Dictionary")
      Data = Range("C9:D" & Target.CurrentRegion.Rows.Count + OffsetRow)
      For lngY = 1 To UBound(Data)
         Unique = Data(lngY, 1) & Data(lngY, 2)
         If Unique <> vbNullString And Not dict.Exists(Unique) Then
            dict.Add Unique, 1
         Else
            If Unique <> vbNullString Then
               Cells(lngY + OffsetRow, 3).Interior.Color = RGB(255, 0, 0)
               Cells(lngY + OffsetRow, 4).Interior.Color = RGB(255, 0, 0)
            End If
         End If
      Next lngY
      OffsetRow = 0
      Unique = vbNullString
      Erase Data
      Set dict = Nothing
   End If
End Sub

' used to identify Duplicates as Red entered within specific Columns in Contiguous Rows and raise an alert
' also sets the default Cell Color to No Fill or White.  comment out the alert if not required
Private Sub Worksheet_Change(ByVal Target As Range)
   ' comment this check out if using Copy & Paste to allow the Event Handler to confirm changes
   If Target.Columns.Count > 1 Then Exit Sub
   If Not Intersect(Target, Range("C:D")) Is Nothing Then
      Application.ScreenUpdating = False
      Dim lngY As Long
      Dim Unique As String
      Dim Data As Variant
      Dim dict As Object
      Dim OffsetRow As Long
      Dim Duplicates As Boolean
      OffsetRow = Target.CurrentRegion.Cells(2, 1).Row
      Set dict = CreateObject("Scripting.Dictionary")
      Data = Range("C9:D" & Target.CurrentRegion.Rows.Count + OffsetRow)
      For lngY = 1 To UBound(Data)
         Unique = Data(lngY, 1) & Data(lngY, 2)
         If Unique <> vbNullString And Not dict.Exists(Unique) Then
            dict.Add Unique, 1
            Cells(lngY + OffsetRow, 3).Interior.Pattern = xlNone '.Interior.Color = RGB(255, 255, 255)
            Cells(lngY + OffsetRow, 4).Interior.Pattern = xlNone '.Interior.Color = RGB(255, 255, 255)
         Else
            If Unique <> vbNullString Then
               Duplicates = True
               Cells(lngY + OffsetRow, 3).Interior.Color = RGB(255, 0, 0)
               Cells(lngY + OffsetRow, 4).Interior.Color = RGB(255, 0, 0)
            End If
         End If
      Next lngY
      OffsetRow = 0
      Unique = vbNullString
      Erase Data
      Set dict = Nothing
      If Duplicates = True Then MsgBox "Duplicates exist and have been highlighted Red", vbCritical, ThisWorkbook.Name
      Duplicates = False
   End If
End Sub




Import CSV Data from a Closed Workbook or File

Here is Code to import CSV data from a closed File or File (the Directory is hard-coded in the Function itself). The Function itself does not return a value, but could by capturing any errors and setting the return Boolean accordingly:


Function ImportCSV(ByVal Filename As String, ByVal Worksheet As String, ByVal StartCell As String) As Boolean
    
    Dim strDirectory As String
    Dim strConnectionName As String

    strDirectory = ThisWorkbook.Worksheets("Setup").Range("APDFilepath")
    strConnectionName = "TEXT;" + strDirectory + "\" + Filename

    With Worksheets(Worksheet).QueryTables.Add(Connection:=strConnectionName, _
                                               Destination:=Worksheets(Worksheet).Range(StartCell))
        .Name = Filename
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True    'False
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .Refresh BackgroundQuery:=False
    End With
    
End Function




Copy Text to the Clipboard without API Calls (Function)


Here is Code to Copy some Text to the Clipboard:


Function CopyTextToClipboard(ByVal Text As String)
  Dim objClipboard As Object
  Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  objClipboard.SetText Text
  objClipboard.PutInClipboard
  Set objClipboard = Nothing
End Function




Hyperlist - Fast, Fuzzy Criteria Delete Rows in a Worksheet


Here is a very fast method to Delete all Rows in a Worksheet for a Header Range matching or containing Numbers, Text, Fuzzy etc. Create a Class Module and Name it ‘HyperFilter’. Add the Code below:


' force explicit variable declaration
Option Explicit

' set default array subscripts to 1
Option Base 1

' set default comparison method to use when comparing string data
Option Compare Text

' vars
Private HyperFilterSheet As Worksheet
Private HyperFilterHeader As Range
Private HyperFilterSheetRange As Range
Private HyperFilterRange As Range

' a call to this method will Delete all Rows in a Worksheet for a Header Range matching Containing Numbers, Text, Fuzzy etc.
' HyperFilter - Fast, Fuzzy Delete Rows by Mark Kubiszyn
Public Sub DeleteRows(FilterWorksheet As Worksheet, _
                      FilterHeader As Range, _
                      Containing As String)
    Application.ScreenUpdating = False
    ' // set the Worksheet
    Set HyperFilterSheet = FilterWorksheet
    ' // initialise & apply the HyperFilter
    With HyperFilterSheet
        .AutoFilterMode = False
        Set HyperFilterSheetRange = Range(FilterHeader, Range(Split(Cells(, FilterHeader.Column).Address, "$")(1) & .Cells(.Rows.Count, FilterHeader.Column).End(xlUp).Row))
        Set HyperFilterRange = .Range(HyperFilterSheetRange.Address)
        HyperFilterRange.AUtofilter Field:=1, Criteria1:=Containing
        If HyperFilterRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Count > 1 Then
            HyperFilterRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
        End If
        .AutoFilterMode = False
    End With
End Sub

Then in any Code Module add the Following Code and configure accordingly to delete all Rows:


Public Sub Example()

' instantiate the class into an object avoiding auto-instancing
Dim Filter As HyperFilter
Set Filter = New HyperFilter
  
 ' fuzzy, apply the HyperFilter to Delete Rows in a Worksheet for a Header Range in B1 matching ‘*Me*’ (anything containing the Text Me)
Filter.DeleteRows FilterWorksheet:=Sheet1, FilterHeader:=Range("B1"), Containing:="*Me*"

End Sub

You can download an Example Workbook here HyperFilter.xlsm




AutoFilter and Range.AutoFilter


Here is Code to use the AutoFilter to Filter data in Column A or to use the AutoFilter member of the Range Object to do the same thing. Add the Code to a Standard Code Module and add some data in Column A. For these Examples add some Numeric data or use the Formula =RAND()*999 to generate some dummy Numeric data and then run the Examples (configure as you require):


' use the AutoFilter Method of a Range Object on Column "A"
Sub Example1()

    Dim rngRange As Range
    Set rngRange = Columns(1)
    rngRange.AutoFilter 1, ">50"

End Sub

' perform a normal AutoFilter on Column "A"
Sub Example2()
    Range("A1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A:$A").AutoFilter Field:=1, Criteria1:=">=17", Operator:=xlAnd, Criteria2:="<=32"
    'ActiveSheet.Range("$A:$A").AutoFilter Field:=1, Criteria1:="=*78.536*"
    'Selection.AutoFilter
End Sub




Arithmetic Coding, a Static Model Test in Excel


A couple of Years ago I wrote a simple Static Model in VBA to perform Arithmetic Coding for a few Bytes. Here is my Code and a File Example to Download - Arithmetic Coding Simple Static Model for Excel.xlsm. Please Note: to run, create a test TXT File and modify the 2 Paths in the Code:


' Arithmetic Coding Static Model VBA Example designed by Mark Kubiszyn

Option Explicit

' the static model
Private Type STATIC_MODEL
 character As String            ' char
 symbol As Integer              ' symbol
 frequency As Double            ' frequency
 probability As Double          ' probablility
 cdf_minus1 As Double           ' cumulative distribution function of previous symbol, default = 0
 cdf As Double                  ' cumulative distribution function [0-1]
End Type

' the count of unique symbols
Private symbols As Long

Public Sub Example()

    ' vars
    Dim f(2 ^ 8) As Long        ' frequency array
    Dim fs As Long              ' file size
    Dim fp As Long              ' file pointer
    Dim ch_minus1 As Double     ' previous char
    Dim ch As Long              ' char
    Dim r As Double             ' range
    Dim h As Double             ' high
    Dim l As Double             ' low

    ' read in file to compute frequency for all symbols, f()
    Open "C:\Users\mark\Desktop\a.txt" For Binary As #1
    For fp = 1 To LOF(1)
        ch = Asc(Input(1, #1))
        f(ch) = f(ch) + 1
    Next fp
    fs = LOF(1)
    Close #1

    ' populate the static model
    ' update character, symbol & frequency
    ' compute probability & cumulative distribution
    Dim M(2 ^ 8) As STATIC_MODEL
    symbols = 0
    For fp = 0 To 2 ^ 8 - 1    'UBound(f) - 1
        If f(fp) > 0 Then
            symbols = symbols + 1
            M(fp).character = Chr$(fp)
            M(fp).symbol = fp
            M(fp).frequency = f(fp)
            M(fp).probability = f(fp) / fs
            M(fp).cdf_minus1 = ch_minus1
            M(fp).cdf = (ch_minus1 + M(fp).probability)
            ch_minus1 = M(fp).cdf
        End If
    Next fp

    ' encode the symbols
    l = 0#: h = 1#
    Open "C:\Users\mark\Desktop\a.txt" For Binary As #1
    For fp = 1 To LOF(1)
        ch = Asc(Input(1, #1))
        ' arithmetic encoding formula
        r = h - l
        h = l + r * M(ch).cdf
        l = l + r * M(ch).cdf_minus1
        Debug.Print "Ascii: " & ch & ", " & _
                    "Char: " & Chr$(ch) & ", " & _
                    "Low: " & l & ", " & _
                    "High: " & h & ", " & _
                    "Range: " & r
    Next fp
    fs = LOF(1)
    Close #1
    ' set midpoint
    l = (h + l) / 2
    Debug.Print ">> Value to Encode: " & l

    ' decode test!
    Dim s As String
    Dim i As Long
    s = ""
    For i = 1 To fs
        For fp = 0 To 2 ^ 8 - 1
            If M(fp).frequency > 0 Then
                If M(fp).cdf_minus1 <= l And l < M(fp).cdf Then
                    s = s & M(fp).character
                    r = M(fp).cdf - M(fp).cdf_minus1
                    l = (l - M(fp).cdf_minus1) / r
                    Debug.Print "Ascii: " & M(fp).character & ", " & _
                                "Char: " & Chr$(M(fp).symbol) & ", " & _
                                "Low: " & l & ", " & _
                                "Range: " & r
                    Exit For
                End If
            End If
        Next fp
    Next i

    MsgBox s

End Sub




Use Hyperlink as a Toggle to Expand & Collapse or Sort a Pivot Table Field Detail


Here is Code to Toggle to Expand & Collapse a Pivot Table Field Detail when a Hyperlink is clicked by a Mouse. Add the Code below to the Worksheet Code Module. It requires 2 Hyperlinks in the ActiveSheet with the Text 'Expand +' and 'Collapse -'. It also requires you to modify the Name of your Pivot Table and the Field to Expand and Collapse accordingly. My Pivot Table was called "Overview" and the Field was called "Deal Mechanic". Here is my Code and a File Example to Download - Promotion Pivot Table Toggle and Sort Example.xlsm:


' Worksheet_FollowHyperlink, all followed hyperlinks will be caught here
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
 
 ' switch on the hyperlink text value, using Range(1,1) allows the use of '&' in Text
 Select Case Target.Range(1, 1).Value

  ' expand
  Case "Expand +"
  ActiveSheet.PivotTables("Overview").PivotFields("Deal Mechanic").ShowDetail = True
 
  ' collapse
  Case "Collapse -"
  ActiveSheet.PivotTables("Overview").PivotFields("Deal Mechanic").ShowDetail = False
 
 End Select

End Sub

And here is the Code to Sort by a Pivot Table Field Column Ascending or Descending using a single Hyperlink 'Sort by Accuracy Desc'. It toggles the Hyperlink Text to "Sort by Accuracy Asc" and the ScreenTip to "Sort by Accuracy Ascending". My Pivot Table was called "Overview" and the Field Sorted was called "Deal Mechanic"


' Worksheet_FollowHyperlink, all followed hyperlinks will be caught here
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
 
 ' switch on the hyperlink text value, using Range(1,1) allows the use of '&' in Text
 Select Case Target.Range(1, 1).Value

  ' sort by accuracy asc
  Case "Sort by Accuracy Asc"
  ActiveSheet.PivotTables("Overview").PivotFields("Deal Mechanic").AutoSort _
   xlDescending, "Deal Absolute Accuracy", ActiveSheet.PivotTables("Overview"). _
    PivotColumnAxis.PivotLines(3), 1
  ActiveCell.Value = "Sort by Accuracy Desc"
  Selection.Hyperlinks(1).ScreenTip = "Sort by Accuracy Descending"

  ' sort by accuracy desc
  Case "Sort by Accuracy Desc"
  ActiveSheet.PivotTables("Overview").PivotFields("Deal Mechanic").AutoSort _
   xlAscending, "Deal Absolute Accuracy", ActiveSheet.PivotTables("Overview"). _
    PivotColumnAxis.PivotLines(3), 1
  ActiveCell.Value = "Sort by Accuracy Asc"
  Selection.Hyperlinks(1).ScreenTip = "Sort by Accuracy Ascending"
 
 End Select

End Sub




Copy a Resized Range from one Worksheet to Another


Here is the Code to Copy a Resized Range from one Worksheet to Another. Here is my Code and a File Example to Download - Copying Ranges.xlsm:


Option Explicit

' CopyResizedRange
Sub CopyResizedRange()

    ' vars
    Dim rngCell As Range
    Dim rngRangeToCopyFrom As Range
    Dim rngRangeToCopyTo As Range
    Dim lngEachCopiedRow As Long
    Dim vntRowData As Variant
    
    Const COLUMN_START As Integer = 0 ' set to -1 to pickup data before your first Column
    Const COLUMN_COPY_START As Integer = 2 ' set to the Column to pickup data from
    Const ROW_WIDTH As Integer = 10   ' increment if you use a minus value above
    Const HEADER_A As String = "Data"
    Const HEADER_B As String = "Data"

    ' set Range to Sheet1
    Set rngRangeToCopyFrom = Sheets("Sheet1").Cells.Find(HEADER_A, , , , xlByRows, xlNext).CurrentRegion.Columns(1).Rows.Offset(1)

    ' set Range to Sheet2
    Set rngRangeToCopyTo = Sheets("Sheet2").Cells.Find(HEADER_B, , , , xlByRows, xlNext).CurrentRegion.Columns(1).Rows
    Set rngRangeToCopyTo = rngRangeToCopyTo.Rows(rngRangeToCopyTo.Rows.Count + 1)

    ' copy the Resized Ranges
    For Each rngCell In rngRangeToCopyFrom
        If rngCell.Value <> "" Then
            vntRowData = rngCell.Resize(COLUMN_COPY_START, ROW_WIDTH).Cells
            ' copy over initial values
            rngRangeToCopyTo.Offset(lngEachCopiedRow, COLUMN_START).Resize(1, ROW_WIDTH).Cells = vntRowData
            lngEachCopiedRow = lngEachCopiedRow + 1
         End If
    Next rngCell

End Sub




Snatch Extreme Data Pulling for Excel


Use these Subroutines to pull data from Closed or Open Workbooks regardless of whether or not the current data has been Saved - download Snatch_v1.zip. The Files should be in the same Folder. The parameters you need to modify will be the second part of the .FormulaArray line ie. "FileA.xlsx" to YOUR FILENAME, "Sheet1" to YOUR WORKSHEET that you are pulling data from and "A1:D101" to YOUR DATA RANGE in the Closed Workbook. The part With Me.Range("A1:D101") is the Range where the data will be pulled into in the Active Workbook. Tip to pull data from CSV Files use my SnatchODBC Examples detailed below:


' 1. Snatch hard-coded Range of current data from an open or closed File called FileA.xlsx
Public Sub Example1()

   With Me.Range("A1:D101")
      .ClearContents
      .FormulaArray = "='" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "A1:D101"
      .Value2 = .Value2
   End With

End Sub



' 2. Snatch the number of Rows available in Column A from an open or closed File called FileA.xlsx
Public Sub Example2A()

   With Me.Range("A5")
      .ClearContents
      .FormulaArray = "=COUNTA('" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "A:A" & ")"
      .Value2 = .Value2
   End With

End Sub

' - using Short Notation
Public Sub Example2B()

   [A5].FormulaArray = "=COUNTA('" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "A:A" & ")"
   [A5].Value2 = [A5].Value2

End Sub

' - using Short Notation and reduced Code
Public Sub Example2C()

   [A5] = "=COUNTA('" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "A:A)"
   [A5] = [A5].Value2

End Sub

' - using Short Notation and reduced Code with the .Formula Member
Public Sub Example2D()

   [A5].Formula = "=COUNTA('" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "A:A)"
   [A5] = [A5].Value2

End Sub




' 3. Snatch a dynamic Range of current data from an open or closed File called FileA.xlsx using a Defined Name
' and a dynamic Formula in FileA.xlsx (1 Defined Name and 1 Cell in FileA.xlsx and 1 Cell required for Storage)
Public Sub Example3A()
   
   With Me.Range([J5].Value2)
      .ClearContents
   End With

   With Me.Range("J5")
      .ClearContents
      .FormulaArray = "='" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "DataRangeAddress"
      .Value2 = .Value2
   End With

   With Me.Range([J5].Value2)
      .FormulaArray = "='" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & [J5].Value2
      .Value2 = .Value2
   End With

End Sub

' - using Short Notation and reduced Code
Public Sub Example3B()
   
   With Me
      .Range([J5].Value2).ClearContents
      .Range("J5") = "='" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "DataRangeAddress"
      .Range("J5") = .Range("J5").Value2
      .Range([J5].Value2) = "='" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & [J5].Value2
      .Range([J5].Value2) = .Range([J5].Value2).Value2
   End With

End Sub




' 4. Snatch a dynamic Range of current data from an open or closed File called FileA.xlsx
' using Formula to pull the Last Column Letter and the Number of Rows
Public Sub Example4()
   
   With Me.Range("A1:" & [J5].Value2 & [J6].Value2)
      .ClearContents
   End With
   
   With Me.Range("J5")
      .ClearContents
      .FormulaArray = "=COUNTA('" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "1:1" & ")"
      .Value2 = .Value2
      .Value2 = Left$(Me.Cells(1, Int(.Value2)).Address(1, 0), InStr(1, Me.Cells(1, Int(.Value2)).Address(1, 0), "$") - 1)
   End With
    
   With Me.Range("J6")
      .ClearContents
      .FormulaArray = "=COUNTA('" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "A:A" & ")"
      .Value2 = .Value2
   End With
   
   With Me.Range("A1:" & [J5].Value2 & [J6].Value2)
      .ClearContents
      .FormulaArray = "='" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "A1:" & [J5].Value2 & [J6].Value2
      .Value2 = .Value2
   End With

End Sub




' 5. Predetermined Range pull that replaces zeros with Blanks 
Public Sub Example5()

   With Me.Range("A1:D500")
      .ClearContents
      .FormulaArray = "='" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet1" & "'!" & "A1:D500"
      .Value2 = .Value2
      .Replace What:="0", Replacement:="", LookAt:=xlWhole
   End With

End Sub




' 6. MY FAVOURITE METHOD!
' Snatch detailing how to bring back data setting Blanks to Blank and NOT zero, persisting zeros
' and correcting any #N/A and #VALUE! Errors - uses Sheet2 in the FileA.xlsx Workbook ;)
Public Sub Example6()

   With Me.Range("A2:C9")
      .ClearContents
      .FormulaArray = "='" & ThisWorkbook.Path & "\[" & "FileA.xlsx" & "]" & "Sheet2" & "'!" & "B2:D9&"""""
      .Value2 = .Value2
      .Replace What:="#N/A", Replacement:="", LookAt:=xlWhole
      .Replace What:="#VALUE!", Replacement:="", LookAt:=xlWhole
   End With

End Sub





Snatch ODBC Extreme Data Pulling for Excel


Use these Subroutines to pull data using ODBC from Closed or Open Workbooks - download SnatchODBC_v1.zip. The Files should be in the same Folder. No References are required. You can choose whether to preserve Formatting, Auto-fit Columns and Overwrite the data. You can also simply add the connection and SQL and then just refresh the data going forward - it's up to you! Download my Examples and start pulling data using ODBC:


' Use in a Public Module or a Worksheet Code Module
Option Explicit

Public Sub Example1()

   Dim Connection As String
   Dim SQL As String
   Dim QT As QueryTable

   With Me
      If .QueryTables.Count > 0 Then .QueryTables(1).Delete
      Connection = "ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.Path & "\" & "FileB.xlsx" & ";"
      SQL = "SELECT ID, Name, Company, Email FROM Data WHERE Name Like 'A%' ORDER BY ID, Name ASC"
      Set QT = .QueryTables.Add(Connection, .Range("A1"), SQL)
      QT.Name = "Example1"
      QT.PreserveFormatting = True
      QT.RefreshStyle = xlOverwriteCells
      QT.Refresh
   End With

End Sub

Public Sub Example1Refresh()

   With Me.QueryTables(1)
      .Refresh
   End With

End Sub

And here are many Examples of using an SQL Statement to pull data from single or multiple Worksheets. The SQL is read from a Cell using Short Notation and can be one of the following SQL Strings, assuming you have downloaded the SnatchODBC_v1.zip Example Zip containing the FileB.xlsx for the data

SELECT * FROM [Sheet1$]
SELECT [ID], [Name], [Email] FROM [Sheet1$]
SELECT [ID], [Name] FROM [Sheet1$] WHERE [Name] Like 'A%' ORDER BY ID, Name ASC
SELECT [Email] FROM [Sheet1$] WHERE [Name] Like 'A%' ORDER BY ID, Name ASC
SELECT [Sheet1$].[Name] as [Full Name], [Sheet1$].[Email] as [Contact Email Address] FROM [Sheet1$]
SELECT [Sheet2$].[Access], [Sheet1$].[ID] as [Joined ID], [Sheet1$].[Name] as [Full Name], [Sheet1$].[Email] as [Contact Email Address] FROM [Sheet1$] INNER JOIN [Sheet2$] ON [Sheet1$].[ID]=[Sheet2$].[ID] WHERE [Sheet2$].[Access] = 'High'


' Use in a Public Module or a Worksheet Code Module
Option Explicit

Public Sub Example2()

   Dim Connection As String
   Dim SQL As String
   Dim QT As QueryTable

   With Me
      ' can be commented out if you will just refresh after adding the QueryTable
      If .QueryTables.Count > 0 Then .QueryTables(1).Delete
      
      ' only for the demo!
      Application.ScreenUpdating = False
      .Columns("A:D").ClearContents
      .Columns("A:D").ColumnWidth = "24"
      
      Connection = "ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.Path & "\" & "FileB.xlsx" & ";"
      SQL = CStr([L17].Value2)
      Set QT = .QueryTables.Add(Connection, .Range("A1"), SQL)
      QT.Name = "Example1"
      QT.PreserveFormatting = True
      QT.RefreshStyle = xlOverwriteCells
      QT.AdjustColumnWidth = True
      QT.Refresh
   End With

End Sub

Public Sub Example2Refresh()

   With Me.QueryTables(1)
      .Refresh
   End With

End Sub

And here are a couple of DAO Examples of pulling data from Access. One Example pulls data from an Access Table and the other pulls data from an Access Query - you can download the Examples here SnatchDAO_v1.zip


Option Explicit

Private Sub UpdateDataFromAccess()

   Dim DB As DAO.Database
   Dim RS As DAO.Recordset
   Dim FLD As Long

   ' retrieve data from Access Table
   Set DB = DBEngine.OpenDatabase(ThisWorkbook.Path & "\FileC.accdb")
   Set RS = DB.OpenRecordset("Select [Data].[ID], [Data].[Name], [Data].[Company] From [Data]") ' WHERE [Data].[Name] Like 'A%'")
   With Me
      .Range("A:E").ClearContents
      ' output Headers
      For FLD = 1 To RS.Fields.Count
        .Cells(1, FLD) = RS.Fields(FLD - 1).Name
      Next FLD
      .Rows("1:1").Font.Bold = True
      .Range("A2").CopyFromRecordset RS
      .Columns.AutoFit
   End With
   RS.Close
   DB.Close

End Sub

Private Sub UpdateQueryDataFromAccess()

   Dim DB As DAO.Database
   Dim RS As DAO.Recordset
   Dim QD As DAO.QueryDef
   Dim FLD As Long

   ' retrieve data from Access Table
   Set DB = DBEngine.OpenDatabase(ThisWorkbook.Path & "\FileC.accdb")
   Set QD = DB.QueryDefs("Employee Details and Country of Work")
   Set RS = QD.OpenRecordset()
   With Me
      .Range("A:E").ClearContents
      ' output Headers
      For FLD = 1 To RS.Fields.Count
        .Cells(1, FLD) = RS.Fields(FLD - 1).Name
      Next FLD
      .Rows("1:1").Font.Bold = True
      .Range("A2").CopyFromRecordset RS
      .Columns.AutoFit
   End With
   RS.Close
   DB.Close

End Sub




Use ODBC and SQL to Aggregate Column Data from one Worksheet to Another using SUM

Here is Code to Aggregate Column Data from one Worksheet to Another using SUM (modify for your own purposes) - you can download an excellent Example here for Product, Product by Location and Product by Customer Aggregation Aggregate.xlsm:


Private Sub AggregatePromoMI()

   Const OutputCell As String = "A1"
   Dim Connection As String
   Dim SQL As String
   Dim QT As QueryTable

   ' picks up 12 weeks of Column Headers
   Dim Weeks As Variant
   Weeks = Application.Transpose(Application.Transpose(PromoMI.Range("E1:P1").Cells))

   With AggregatedPromoMI
      .Range("A1").CurrentRegion.ClearContents
      If .QueryTables.Count > 0 Then .QueryTables(1).Delete
      Connection = "ODBC;DSN=Excel Files;HDR=NO;DBQ=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";"
      SQL = "SELECT [Promo MI$].[APO Product], " & _
            "SUM([Promo MI$].[" & Weeks(1) & "]) as 1, SUM([Promo MI$].[" & Weeks(2) & "]) as 2, SUM([Promo MI$].[" & Weeks(3) & "]) as 3, SUM([Promo MI$].[" & Weeks(4) & "]) as 4, " & _
            "SUM([Promo MI$].[" & Weeks(5) & "]) as 5, SUM([Promo MI$].[" & Weeks(6) & "]) as 6, SUM([Promo MI$].[" & Weeks(7) & "]) as 7, SUM([Promo MI$].[" & Weeks(8) & "]) as 8, " & _
            "SUM([Promo MI$].[" & Weeks(9) & "]) as 9, SUM([Promo MI$].[" & Weeks(10) & "]) as 10, SUM([Promo MI$].[" & Weeks(11) & "]) as 11, SUM([Promo MI$].[" & Weeks(12) & "]) as 12 " & _
            "FROM [Promo MI$] GROUP BY [Promo MI$].[APO Product]"
      
      Set QT = .QueryTables.Add(Connection, .Range(OutputCell), SQL)
      QT.Name = "ODBCAggregateData"
      QT.PreserveFormatting = True
      QT.AdjustColumnWidth = True
      QT.RefreshStyle = xlOverwriteCells
      QT.Refresh
   End With

 Application.DisplayStatusBar = True
 Application.StatusBar = "Aggregated Promo data update complete..."

End Sub




QueryTable, adds and / or refreshes a Recordset from a Worksheet using SQL & ODBC into a Table (ListObject)

Here is Code to use SQL to quickly pull in data from another Worksheet into a Table. Please Note: I find that Code will fail if SQL Strings are too large:


Public Sub QueryTable()

   Dim Connection As Object
   Dim SQL As Object
   Set Connection = CreateObject("ADODB.Connection")
   Set SQL = CreateObject("ADODB.Recordset")
   Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";Extended Properties=Excel 12.0;"

   SQL.Open "Select [Data$].[Product] From [Data$]", Connection
  
   With Sheet1
      ' refresh an existing QueryTable
      If .ListObjects.Count > 0 Then
         With .ListObjects(1).QueryTable
            Set .Recordset = SQL
            .Refresh
         End With
      Else
         ' adds a new Table Object TableQuery for your SQL
         .ListObjects.Add(xlSrcQuery, SQL, Destination:=.Range("A1")).QueryTable.Refresh
      End If
   End With
     
   SQL.Close
   Connection.Close
   Set SQL = Nothing
   Set Connection = Nothing

End Sub




The best way to pull data in my opionion - Fast and Concise ODBC Query Pull using SQL and the Microsoft ActiveX Data Objects 6.1 Library for Object Intellisense

Here is Code to use SQL to quickly pull in data from another Worksheet or Table using ODBC with a reference to Microsoft ActiveX Data Objects 6.1 Library. It will Select everything from a Worksheet called "Data" and includes provision for outputting the Headers:



' Please Note: when using special characters (decimal point) change the (.) into a hash (#) ie. [Yr1 Jan F.] becomes [Yr1 Jan F#]
' - you can always coerse it into whatever Field Name you want ie. [Yr1 Jan F#] as 01_2020

' Whenever you have lots of data on a Sheet, to ensure Excel doesn't get confused using ODBC with Field Names, use an explicit Range linked to the Table
" FROM [Dashboard$B21:GF4500]"

' this is useful when you want to pull from multiple sources - you can use another File directly in the SQL Statement
query.CommandText = "SELECT * FROM [Excel 12.0 Xml;HDR=Yes;Database=" & ThisWorkbook.Path & "\Book1.xlsx].[Sheet1$]"


' add the Code below into any Code Module or Worksheet Code Module (change to use the .Me Object) add remember to add the latest Library reference below
' Microsoft ActiveX Data Objects 6.1 Library
Public Sub ADODBQuery()

   Dim HeaderField As Long
   Dim Connection As ADODB.Connection
   Set Connection = New ADODB.Connection
   Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";Extended Properties=Excel 12.0;"
   Dim query As ADODB.Command
   Set query = New ADODB.Command
   query.ActiveConnection = Connection
    
   query.CommandText = "Select * FROM [Sheet1$]"
   
   query.CommandType = adCmdText
   Debug.Print query.CommandText
   Dim QueryData As ADODB.Recordset
   Set QueryData = query.Execute
   
   With Sheet3 ' or use Me in a Worksheet Code Module
      For HeaderField = 1 To QueryData.Fields.Count
         .Cells(1, HeaderField) = QueryData.Fields(HeaderField - 1).Name
      Next HeaderField
      .Rows("1:1").Font.Bold = True
      .Range("A2").CopyFromRecordset QueryData
      .Columns.AutoFit
   End With

   QueryData.Close
   Connection.Close

End Sub



' use this solution for when a user clicks on a Worksheet Tab - also clears the data when the Worksheet Tab is deselected
Option Explicit

Private Sub Worksheet_Activate()

  Dim HeaderField As Long
   Dim Connection As ADODB.Connection
   Set Connection = New ADODB.Connection
   Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";Extended Properties=Excel 12.0;"
   Dim query As ADODB.Command
   Set query = New ADODB.Command
   query.ActiveConnection = Connection
    
   query.CommandText = "Select * FROM [Sheet1$]"
   
   query.CommandType = adCmdText
   Debug.Print query.CommandText
   Dim QueryData As ADODB.Recordset
   Set QueryData = query.Execute
   
   With Me
      For HeaderField = 1 To QueryData.Fields.Count
         .Cells(1, HeaderField) = QueryData.Fields(HeaderField - 1).Name
      Next HeaderField
      .Rows("1:1").Font.Bold = True
      .Range("A2").CopyFromRecordset QueryData
      .Columns.AutoFit
   End With

   QueryData.Close
   Connection.Close

End Sub

Private Sub Worksheet_Deactivate()
   Application.StatusBar = vbNullString
   Me.Cells.ClearContents
End Sub

' use this solution to check if a combination of Column entries exist in the Master Table, if they do, run an Update query, otherwise run an Insert Query
' this example also shows you how to query the RecordCount member of the Recordset for the number of records using Open() and the CursorLocation
Public Sub Update()

   Dim DataSheet As String
   DataSheet = Sheet3.Name
   Dim Connection As ADODB.Connection
   Set Connection = New ADODB.Connection
   Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";Extended Properties=Excel 12.0;"
   Dim QueryData As ADODB.Recordset
   Set QueryData = New ADODB.Recordset
   QueryData.CursorLocation = adUseClient
   Dim query As ADODB.Command
   Set query = New ADODB.Command
   query.ActiveConnection = Connection
   query.CommandType = adCmdText
    
   ' test for an existing combination
   query.CommandText = "SELECT 1 FROM [" & DataSheet & "$] WHERE [Product] = 'Prod1' and [Description] = 'Test'"
   QueryData.Open query.CommandText, Connection
   If QueryData.RecordCount = 1 Then
      ' Update
      query.CommandText = "UPDATE [" & DataSheet & "$] SET [Description]='Poo' WHERE [Product]='Prod1'"
   Else
      ' Insert
      query.CommandText = "INSERT INTO [" & DataSheet & "$] ([Product], [Description]) VALUES ('Prod1', 'Test')"
   End If
   Debug.Print QueryData.RecordCount & " -- " & query.CommandText
   query.Execute
   
   QueryData.Close
   Connection.Close

   Application.DisplayStatusBar = True
   Application.StatusBar = "Update completed OK"

End Sub




Some SQL to use with the ODBC Routine above

Here are some SQL Statements to perform basic tasks ODBC Examples.xlsm:


   ' Method to JOIN and then INSERT/UPDATE ALL Records instantly - edit the linked Uniqued Fields for the JOIN
   Dim Connection As ADODB.Connection
   Set Connection = New ADODB.Connection
   Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";Extended Properties=Excel 12.0;"
   Dim QueryData As ADODB.Recordset
   Set QueryData = New ADODB.Recordset
   QueryData.CursorLocation = adUseClient
   Dim query As ADODB.Command
   Set query = New ADODB.Command
   query.ActiveConnection = Connection
   query.CommandType = adCmdText

   query.CommandText = "INSERT INTO [Data$] ([Product], [Misc4], [Misc6], [S Jan 18], [S Apr 18]) " & _
                       "SELECT [Update$].[Product], [Update$].[Misc4], [Update$].[Misc6], [Update$].[S Jan 18], [Update$].[S Apr 18] " & _
                       "FROM [Update$] " & _
                       "LEFT JOIN [Data$] ON [Data$].[Product]=[Update$].[Product] AND [Data$].[Misc4]=[Update$].[Misc4] AND [Data$].[Misc6]=[Update$].[Misc6]" & _
                       "WHERE [Data$].[Product] IS NULL"

   Debug.Print query.CommandText
   query.Execute


  query.CommandText = "UPDATE [Data$] " & _
                      "INNER JOIN [Update$] ON [Data$].[Product]=[Update$].[Product] AND [Data$].[Misc4]=[Update$].[Misc4] AND [Data$].[Misc6]=[Update$].[Misc6] " & _
                      "SET [Data$].[S Jan 18]=[Update$].[S Jan 18], [Data$].[S Apr 18]=[Update$].[S Apr 18]"
   query.Execute
   Connection.Close



' check to see if a combination exists, if the RecordCount = 1 then it does, therefore use an Update Query otherwise use an Insert Query
"SELECT 1 FROM [" & DataSheet & "$] WHERE [Product] = 'Prod1' and [Description] = 'Test'"
"UPDATE [" & DataSheet & "$] SET [Description]='Poo' WHERE [Product]='Prod1'"
"INSERT INTO [" & DataSheet & "$] ([Product], [Description]) VALUES ('Prod1', 'Test')"

' Unions will bring back all unique records from multiple Tables ie. Sheet1 and Sheet2 (comparing items across all Fields)
query.CommandText = "TABLE [Sheet1$] UNION TABLE [Sheet2$]"
query.CommandText = "SELECT [Product], [Description] FROM [Sheet1$] UNION SELECT [Product], [Description] FROM [Sheet2$]"

' this is like a full OUTER QUERY UNION only bringing back DISTINCT Fields from 1 or more Columns
query.CommandText = "Select DISTINCT * From (select [Sheet1$].[Product] from [Sheet1$] LEFT Join [Sheet2$] ON [Sheet1$].[Product] =[Sheet2$].[Product] Union select [Sheet2$].[Product] from [Sheet2$] Left Join [Sheet1$] ON [Sheet2$].[Product] = [Sheet1$].[Product])"
query.CommandText = "Select DISTINCT * From (select [Sheet1$].[Product], [Sheet1$].[Description] from [Sheet1$] LEFT Join [Sheet2$] ON [Sheet1$].[Product] =[Sheet2$].[Product] Union select [Sheet2$].[Product], [Sheet2$].[Description] from [Sheet2$] Left Join [Sheet1$] ON [Sheet2$].[Product] = [Sheet1$].[Product])"



' A term that often comes up when discussing joins is the Cartesian product. A Cartesian product is defined as
' "all possible combinations of all rows in all tables." For example, if you were to join two tables without any kind 
' of qualification or join type, you would get a Cartesian product
' this brings back all combinations of Records from 2 Worksheets, sorted by the Product Field from Sheet1
query.CommandText = "SELECT * FROM [Sheet1$], [Sheet2$] ORDER BY [Sheet1$].[Product]"

' An OUTER JOIN is used to retrieve records from multiple tables while preserving records from one of the tables, even if
' there is no matching record in the other table
' The LEFT OUTER JOIN selects all rows in the right table that match the relational comparison criteria, and also selects all
' rows from the left table, even if no match exists in the right table (if Product C is only in Sheet2 it will not be returned)
query.CommandText = "SELECT [Sheet1$].[Product], [Sheet1$].[Description] FROM [Sheet1$] LEFT OUTER JOIN [Sheet2$] ON [Sheet1$].[Product] = [Sheet2$].[Product]"
' The RIGHT OUTER JOIN is simply the reverse of the LEFT OUTER JOIN; all rows in the right table are preserved instead

' The INNER JOIN, also known as an equi-join, is the most commonly used type of join. This join is used to retrieve rows from
' two or more tables by matching a field value that is common between the tables (will return multiple records)
query.CommandText = "SELECT [Sheet1$].[Product], [Sheet1$].[Description] FROM [Sheet1$] INNER JOIN [Sheet2$] ON [Sheet1$].[Product] = [Sheet2$].[Product]"
' will return the unique or Groouped records - remember aggregate Functions require you to add both parts of the Select Fields to the GROUP BY clause
query.CommandText = "SELECT [Sheet1$].[Product], [Sheet1$].[Description] FROM [Sheet1$] INNER JOIN [Sheet2$] ON [Sheet1$].[Product] = [Sheet2$].[Product] GROUP BY [Sheet1$].[Product], [Sheet1$].[Description]"
' you can also use the WHERE clause to filter by some Criteria
query.CommandText = "SELECT [Sheet1$].[Product], [Sheet1$].[Description] FROM [Sheet1$] INNER JOIN [Sheet2$] ON [Sheet1$].[Product] = [Sheet2$].[Product] WHERE [Sheet1$].[Description] = 'KEG' GROUP BY [Sheet1$].[Product], [Sheet1$].[Description]"
' use the LIKE clause wrapping with % for fuzzy matching
query.CommandText = "SELECT [Sheet1$].[Product], [Sheet1$].[Description] FROM [Sheet1$] INNER JOIN [Sheet2$] ON [Sheet1$].[Product] = [Sheet2$].[Product] WHERE [Sheet1$].[Product] LIKE '%b%' GROUP BY [Sheet1$].[Product], [Sheet1$].[Description]"




How to Force a User to Enter a Value in a Cell before Closing or Saving a Workbook for a Required Parameter

Here is some simple Code to prevent a Workbook from being Saved and / or Closed without a required parameter in some Cell Force Cell entry value before saving.xlsm:



' add this to the ThisWorkbook Code Module
Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
 If Sheet1.Range("A1").Value2 = vbNullString Then MsgBox "Enter the required parameter in Cell A1", vbExclamation, ThisWorkbook.Name: Cancel = True
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 If Sheet1.Range("A1").Value2 = vbNullString Then MsgBox "Enter the required parameter in Cell A1", vbExclamation, ThisWorkbook.Name: Cancel = True
End Sub



' or for multiple Cells you can modify this Code by Tim Williams, published here https://stackoverflow.com/questions/31861063/excel-make-a-field-required-before-saving-but-let-me-save-the-blank-form
Option Explicit

Dim msg As String

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    msg = ""

    If Sheets("Sheet1").Range("A1").Value <> "" Then
        Sheets("Sheet1").Range("A1").Value = ""
        Exit Sub
    End If

    EmptyCell Sheets("Report").Range("B3"), "Submitter"
    EmptyCell Sheets("Sheet1").Range("B4"), "Time/Date"
    EmptyCell Sheets("Sheet1").Range("B5"), "Customer Info"
    EmptyCell Sheets("Sheet1").Range("B6"), "Issue Description"
    EmptyCell Sheets("Sheet1").Range("B7"), "Repeatable"

    If Len(msg) > 0 Then
        MsgBox "The following values are required before saving:" & _
                 vbLf & msg, vbExclamation
        Cancel = True
    End If

End Sub

Sub EmptyCell(rng As Range, msgErr As String)
    If rng.Value = "" Then msg = msg & vbLf & msgErr & _
       "   (" & rng.Parent.Name & "," & rng.Address(False, False) & ")"
End Sub




Select a File using an Input Box and Copy multiple Single Cells of Data into Another Workbook


Here is the Code to Select a File using an Input Box and Copy multiple Single Cells of Data into Another Workbook. You have a couple of Options with this Code. 2 options. 1. run in PERSONAL BOOK with a Macro button. 2. run manually or from a Button in a Macro-enabled Workbookcan run this:


Option Explicit

' GetContractChangeDataMacro, allows Workbook switching to retrieve data from a dspMaterial File
' - you can do this using Find and Offset(), but if things change, you will still need to change the Code!
Public Sub GetContractChangeDataMacro()
   ' edit these for the required Cells
   ' - SheetNameToCopyTo, change this to the name of the Sheet that you want to Copy Cells into
   ' - NumberOfCellsToCopy, increase this variable for any new pairs of Cells
   ' - CellsToReadWrite, left-side are the Cells to write to, right-side are the Cells to Read from.  Extend the variable to add more key/item pairs
   Const SheetNameToCopyTo As String = "3PP contract change"
   Const NumberOfCellsToCopy As Long = 4
   Dim CellsToReadWrite As Variant
   ' Material, Description, Vendor, Vendor Name
   CellsToReadWrite = [{"G6","O9";  "H6","B9";  "D6","D69";  "E6","D61"}]
   Dim X As Long
   Dim Data As Range
   On Error Resume Next
   Application.DisplayAlerts = False
   Set Data = Application.InputBox("Switch to the dspMaterial File and Select any Cell on the Sheet to retrieve the Contract Change Data" & vbLf & vbLf & _
   "Press OK to copy the data...", "Get Contract Change Data", Type:=8)
   If Not Err.Number = 424 Then
      If (Data Is Nothing) = False Then
         If Data.Parent.Name <> "Internal Use Only" Then
          MsgBox "File was not a Material Master Form", vbExclamation, "Get Contract Change Data"
         Else
         Application.ScreenUpdating = False
         With ThisWorkbook.Sheets(SheetNameToCopyTo)
            For X = 1 To NumberOfCellsToCopy
               .Range(CellsToReadWrite(X, 1)).Value2 = _
               Workbooks(Data.Parent.Parent.Name).Sheets(Data.Parent.Name).Range(CellsToReadWrite(X, 2)).Value2
            Next X
         End With
         End If
      End If
   End If
   On Error GoTo 0
   Application.ScreenUpdating = True
End Sub




Detecting Mouse Buttons and/or Keyboard Keypress States


You can use the GetAsyncKeyState Capture Mouse Clicks or Arrows.xlsm Workbook to find out what Mouse Button has been pressed or any Key for that matter:


' add to a Code Module
Option Explicit

#If VBA7 Then
' 64bit API Declarations
Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
' 32bit API Declarations
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If

' in a Worksheet Code Module
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If GetAsyncKeyState(vbKeyShift) And &H8000 Then
        MsgBox "shift key pressed"
    ElseIf GetAsyncKeyState(vbKeyRight) And &H8000 Then
        MsgBox "right arrow pressed"
    ElseIf Not GetAsyncKeyState(vbKeyRButton) And &H8000 Then
        MsgBox "left arrow pressed"
        ActiveCell.Value2 = Rnd(9999)
    ElseIf GetAsyncKeyState(vbKeyPageUp) And &H8000 Then
        MsgBox "left arrow pageup pressed"
    ElseIf GetAsyncKeyState(vbKeyUp) And &H8000 Then
        MsgBox "up arrow pressed "
    ElseIf GetAsyncKeyState(vbKeyDown) And &H8000 Then
        MsgBox "down arrow pressed "
    ElseIf GetAsyncKeyState(vbKeyEscape) And &H8000 Then
        MsgBox "esc button pressed"
    ElseIf GetAsyncKeyState(vbKeyReturn) And &H8000 Then
        MsgBox "enter button pressed"
    ElseIf GetAsyncKeyState(vbKeyLButton) And &H8000 Then
        MsgBox "left mouse"
    ElseIf GetAsyncKeyState(vbKeyRButton) And &H8000 Then
        MsgBox "right mouse"
    ElseIf GetAsyncKeyState(vbKeyMButton) And &H8000 Then
        MsgBox "middle mouse"
    End If
End Sub

 ' Keypress Constants 
 Private Const VK_LBUTTON = &H1 'Left mouse button
 Private Const VK_RBUTTON = &H2 'Right mouse button
 Private Const VK_CANCEL = &H3 'Control-break processing
 Private Const VK_MBUTTON = &H4 'Middle mouse button (three-button mouse)
 Private Const VK_BACK = &H8 'BACKSPACE key
 Private Const VK_TAB = &H9 'TAB key
 Private Const VK_CLEAR = &HC  'CLEAR key
 Private Const VK_RETURN = &HD  'ENTER key
 Private Const VK_SHIFT = &H10 'SHIFT key
 Private Const VK_CONTROL = &H11 'CTRL key
 Private Const VK_MENU = &H12 'ALT key
 Private Const VK_PAUSE = &H13 'PAUSE key
 Private Const VK_CAPITAL = &H14 'CAPS LOCK key
 Private Const VK_ESCAPE = &H1B 'ESC key
 Private Const VK_SPACE = &H20 'SPACEBAR
 Private Const VK_PRIOR = &H21 'PAGE UP key
 Private Const VK_NEXT = &H22 'PAGE DOWN key
 Private Const VK_END = &H23 'END key
 Private Const VK_HOME = &H24 'HOME key
 Private Const VK_LEFT = &H25 'LEFT ARROW key
 Private Const VK_UP = &H26 'UP ARROW key
 Private Const VK_RIGHT = &H27 'RIGHT ARROW key
 Private Const VK_DOWN = &H28 'DOWN ARROW key
 Private Const VK_SELECT = &H29 'SELECT key
 Private Const VK_PRINT = &H2A 'PRINT key
 Private Const VK_EXECUTE = &H2B 'EXECUTE key
 Private Const VK_SNAPSHOT = &H2C 'PRINT SCREEN key
 Private Const VK_INSERT = &H2D 'INS key
 Private Const VK_DELETE = &H2E 'DEL key
 Private Const VK_HELP = &H2F 'HELP key
 Private Const VK_0 = &H30 '0 key
 Private Const VK_1 = &H31 '1 key
 Private Const VK_2 = &H32 '2 key
 Private Const VK_3 = &H33 '3 key
 Private Const VK_4 = &H34 '4 key
 Private Const VK_5 = &H35 '5 key
 Private Const VK_6 = &H36 '6 key
 Private Const VK_7 = &H37 '7 key
 Private Const VK_8 = &H38 '8 key
 Private Const VK_9 = &H39 '9 key
 Private Const VK_A = &H41 'A key
 Private Const VK_B = &H42 'B key
 Private Const VK_C = &H43 'C key
 Private Const VK_D = &H44 'D key
 Private Const VK_E = &H45 'E key
 Private Const VK_F = &H46 'F key
 Private Const VK_G = &H47 'G key
 Private Const VK_H = &H48 'H key
 Private Const VK_I = &H49 'I key
 Private Const VK_J = &H4A 'J key
 Private Const VK_K = &H4B 'K key
 Private Const VK_L = &H4C 'L key
 Private Const VK_M = &H4D 'M key
 Private Const VK_N = &H4E 'N key
 Private Const VK_O = &H4F 'O key
 Private Const VK_P = &H50 'P key
 Private Const VK_Q = &H51 'Q key
 Private Const VK_R = &H52 'R key
 Private Const VK_S = &H53 'S key
 Private Const VK_T = &H54 'T key
 Private Const VK_U = &H55 'U key
 Private Const VK_V = &H56 'V key
 Private Const VK_W = &H57 'W key
 Private Const VK_X = &H58 'X key
 Private Const VK_Y = &H59 'Y key
 Private Const VK_Z = &H5A 'Z key
 Private Const VK_NUMPAD0 = &H60 'Numeric keypad 0 key
 Private Const VK_NUMPAD1 = &H61 'Numeric keypad 1 key
 Private Const VK_NUMPAD2 = &H62 'Numeric keypad 2 key
 Private Const VK_NUMPAD3 = &H63 'Numeric keypad 3 key
 Private Const VK_NUMPAD4 = &H64 'Numeric keypad 4 key
 Private Const VK_NUMPAD5 = &H65 'Numeric keypad 5 key
 Private Const VK_NUMPAD6 = &H66 'Numeric keypad 6 key
 Private Const VK_NUMPAD7 = &H67 'Numeric keypad 7 key
 Private Const VK_NUMPAD8 = &H68 'Numeric keypad 8 key
 Private Const VK_NUMPAD9 = &H69 'Numeric keypad 9 key
 Private Const VK_SEPARATOR = &H6C 'Separator key
 Private Const VK_SUBTRACT = &H6D 'Subtract key
 Private Const VK_DECIMAL = &H6E 'Decimal key
 Private Const VK_DIVIDE = &H6F 'Divide key
 Private Const VK_F1 = &H70 'F1 key
 Private Const VK_F2 = &H71 'F2 key
 Private Const VK_F3 = &H72 'F3 key
 Private Const VK_F4 = &H73 'F4 key
 Private Const VK_F5 = &H74 'F5 key
 Private Const VK_F6 = &H75 'F6 key
 Private Const VK_F7 = &H76 'F7 key
 Private Const VK_F8 = &H77 'F8 key
 Private Const VK_F9 = &H78 'F9 key
 Private Const VK_F10 = &H79 'F10 key
 Private Const VK_F11 = &H7A 'F11 key
 Private Const VK_F12 = &H7B 'F12 key
 Private Const VK_F13 = &H7C 'F13 key
 Private Const VK_F14 = &H7D 'F14 key
 Private Const VK_F15 = &H7E 'F15 key
 Private Const VK_F16 = &H7F 'F16 key
 Private Const VK_NUMLOCK = &H90 'NUM LOCK key
 Private Const VK_SCROLL = &H91 'SCROLL LOCK key
 Private Const VK_LSHIFT = &HA0 'Left SHIFT key
 Private Const VK_RSHIFT = &HA1 'Right SHIFT key
 Private Const VK_LCONTROL = &HA2 'Left CONTROL key
 Private Const VK_RCONTROL = &HA3 'Right CONTROL key
 Private Const VK_LMENU = &HA4 'Left MENU key
 Private Const VK_RMENU = &HA5 'Right MENU key
 Private Const VK_PLAY = &HFA 'Play key
 Private Const VK_ZOOM = &HFB 'Zoom key

Sub WaitUntilLeftClick()
 Do Until (GetAsyncKeyState(VK_LBUTTON) And &H8000) <> 0
  DoEvents
 Loop
 MsgBox "Hello World"
End Sub




Key Item Pairs - Store and Loop An Array of Settings, Cell References or Defined Names for Speed


Storing Cell References or Defined Names in an Array can help repeating lots of Code. Use a Variable to store Key, Item pairs and then read both of these to update settings in a single line



' like this
Dim DefinedNamesToReadWrite As Variant
DefinedNamesToReadWrite = [{"Code1","ThemeCode1";  "Code1h","ThemeCode1h";  "Code1hWeight","ThemeCode1h"}]

With NewHolidayPlanner.Sheets(SetupSheetName)
 .Activate
 .Unprotect
 For X = 1 To NumberOfDefinedNames
  ' Cell Colour
  .Range(DefinedNamesToReadWrite(X, 1)).Interior.Color = ThisWorkbook.Sheets(ThemeUpdaterSheetName).Range(DefinedNamesToReadWrite(X, 2)).Interior.Color
  ' Font Colour
  .Range(DefinedNamesToReadWrite(X, 1)).Font.Color = ThisWorkbook.Sheets(ThemeUpdaterSheetName).Range(DefinedNamesToReadWrite(X, 2)).Font.Color
 Next X
End WIth


' or like this
' edit these for the required Cells
' - SheetNameToCopyTo, change this to the name of the Sheet that you want to Copy Cells into
' - NumberOfCellsToCopy, increase this variable for any new pairs of Cells
' - CellsToReadWrite, left-side are the Cells to write to, right-side are the Cells to Read from.  Extend the variable to add more key/item pairs
Const SheetNameToCopyTo As String = "3PP contract change"
Const NumberOfCellsToCopy As Long = 10
Dim CellsToReadWrite As Variant
' Material, Description, Vendor Number, Vendor Name, Contract Price, Order Unit, Order Unit, Currency, Contract Number, PPI
CellsToReadWrite = [{"G6","O9";  "H6","N18";  "D6","D69";  "E6","D61";  "O6","E73";  "Q6","P73";  "R6","P73";  "S6","K73";  "T6","L69";  "Z6","E75"}]

With ThisWorkbook.Sheets(SheetNameToCopyTo)
 For X = 1 To NumberOfCellsToCopy
  .Range(CellsToReadWrite(X, 1)).Value2 = _
    Workbooks(Data.Parent.Parent.Name).Sheets(Data.Parent.Name).Range(CellsToReadWrite(X, 2)).Value2
 Next X
End With




Iterating Conditional Formatting


Here are a couple of Subroutines to help you iterate through Conditional Formatting. The first one allows you to isolate Cell Colours for specific Conditional Formatting Formula. The second is not my Code but is a neat little Subroutine to output all of the Conditional Formatting for a Sheet - just change the Worksheet Code Name ie. Sheet1, Sheet2 tec.



' Iterate Conditional Formatting
Public Sub IterateConditionalFormatting()

Dim ConditionalFormatting As FormatCondition
For Each ConditionalFormatting In Sheet3.Cells.SpecialCells(xlCellTypeAllFormatConditions).FormatConditions

Debug.Print "Applies to: " & ConditionalFormatting.AppliesTo.Address & ", Interior Colour: " & ConditionalFormatting.Interior.Color
Debug.Print "Formula1: " & ConditionalFormatting.Formula1
Debug.Print Chr$(10)

If InStr(1, ConditionalFormatting.Formula1, "Code8", vbTextCompare) > 0 Then ConditionalFormatting.Interior.Color = 0

Next ConditionalFormatting

End Sub


' Not my Code.  list Conditional Formatting for a Sheet on a new Sheet using the Code Name (needs rewrite for variable dec but works okay and is a nice little routine)
Sub M_snb()
    On Error Resume Next
    sp = Split("Cell Value|Expression|Color Scale|DataBar|Top 10?|Icon Sets||Unique Values|Text|Blanks|Time Period|Above Average||No Blanks||Errors|No Errors|||||", "|")
    With CreateObject("scripting.dictionary")
        .Item("titel") = "Type|Typename|Range|StopIfTrue|Formula1|Formula2|Formula3"
        ' change Sheet3 for your Sheet to examine!
        For Each cl In Sheet3.Cells.SpecialCells(xlCellTypeAllFormatConditions)
            For Each cf In cl.FormatConditions
                c00 = ""
                c00 = cf.Formula1
               If .exists(cf.AppliesTo.Address) Then
                    If InStr(.Item(cf.AppliesTo.Address), c00) = 0 Then
                     .Item(cf.AppliesTo.Address) = .Item(cf.AppliesTo.Address) & "|'" & c00
                    End If
                Else
                    .Item(cf.AppliesTo.Address) = cf.Type & "|" & sp(cf.Type) & "|" & cf.AppliesTo.Address & "|" & cf.StopIfTrue & "|'" & c00
                End If
            Next
        Next
        Sheets.Add.Name = "overzicht"
        Sheets("overzicht").Cells(1).Resize(.Count) = Application.Transpose(.items)
        Sheets("overzicht").Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "|"
    End With
End Sub




Identify Sorted Table Columns and their Sort Direction using VBA


Here is VBA Code to identify Sorted Table Columns and their Sort Direction in Excel. 1 = Ascending, 2 = Descending The way I found this was to drill right down using a Debug, checking ,evels withint the SortTable Object. What I found was that the Column number is stored for a Sort, deep within the many levels ie. SortTable.Sort.Rng.ListObject.Sort.SortFields.Item(SortOrder).Key.Column where SortOrder is the first Sort - check out the Code below:


' identify Sorted Table Columns and their Sort Direction in Excel.  1 = Ascending, 2 = Descending
Dim SortOrder As Long
Dim SortTable As ListObject
Set SortTable = ActiveSheet.ListObjects(1)

For SortOrder = 1 To SortTable.Sort.SortFields.Count
 Debug.Print SortTable.ListColumns.Item(SortTable.Sort.Rng.ListObject.Sort.SortFields.Item(SortOrder).Key.Column).Name
 Debug.Print SortTable.Sort.SortFields.Item(SortOrder).Order
Next SortOrder




Build & Copy Ranges Quickly


Here is VBA Code to build and Copy a Range elsewhere on another Sheet. I give you a Special Values version and a Copy & Paste version:


Public Sub BuildRangeExampleToCopyRanges()
   
   ' Example
   Dim R As Range
   Set R = BuildRange("Sheet2", "A1", 2, 6)
   'If Not r Is Nothing Then MsgBox r.Address
   
   ' VALUES
   Dim P As Range
   Set P = BuildRange("Sheet2", "D1", 2, 6)
   P.Value = R.Value
   
   ' COPY
   ' r.Copy
   ' p.PasteSpecial Paste:=xlPasteValues
   ' Application.CutCopyMode = False
    
End Sub

' BuildRange() Function, sets & returns a Worksheet Range Object ie. a Worksheet Name, "Sheet1", a Start Cell ie. "D4", 6 Columns and 4 Rows = "D4:I7" (includes the Start Cell Column/Row)
Public Function BuildRange(ByVal WorksheetName As String, ByVal HeaderCell As String, ByVal NumberOfColumns As Long, ByVal NumberOfRows As Long) As Range
   On Error GoTo Catch
   With ThisWorkbook.Sheets(WorksheetName)
      Set BuildRange = .Range(HeaderCell, .Range(Left$(.Cells(1, Int(NumberOfColumns + .Range(HeaderCell).Column - 1)).Address(1, 0), _
      InStr(1, .Cells(1, Int(NumberOfColumns + .Range(HeaderCell).Column)).Address(1, 0), "$") - 1) & .Range(HeaderCell).Row + NumberOfRows - 1)).Cells
   End With
   Exit Function
Catch:
   Set BuildRange = Nothing
End Function