Welcome to my VBA 'Made Simple' Section. Here you will find my quick Coding Techniques using Visual Basic for Applications

Please feel free to download and share my work - you can use the Code and techniques to develop your own Excel Workbooks. Please note the licensing terms and conditions whenever using or distributing my work

You can read about any updates to this section or follow my work on Facebook
If you have used any of my other work and wish to donate, you can do so on my Donate Page


Removing Row Duplicates

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

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

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

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


Replacing Zeros with Blanks

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

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

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

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

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

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


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

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

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

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


Deleting Rows in a Column for Cells that are Blank

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

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

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

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


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

You can use the following methods to Copy Formula down a dynamic Column Range (assumes dat 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)

' alternative method to Copy down Formula with AutoFill in Column B to the last Row
Range("B2").AutoFill Destination:=Range("B2:B" & 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:
You can find more Code to iterate Ranges here together with a download Worksheet of the examples (type 'iterate' into the Search box)

' 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
 


Finding the Last Row or First/Last Available Blank Row

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

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

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

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

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

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

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

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

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


Finding the Last Column

Here are methods to get the last Column:

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

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

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


Checking for the existence of Data below Headers

Here are methods to check whether data is present:

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

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


Get Data from a Closed Workbook as Special Values very Fast

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

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

' ## GetValuesFromAClosedWorkbook, retrieves Special Values for data in a Closed Excel Workbook
Private Sub GetValuesFromAClosedWorkbook(ByVal strFilepath As String, ByVal strFilename As String, ByVal strSheet As String, ByVal strRange As String, ByVal strActiveSheet As String)
    With Sheets(strActiveSheet).Range(strRange)
        .FormulaArray = "='" & strFilepath & "\[" & strFilename & "]" & strSheet & "'!" & strRange
        .Value = .Value
    End With
End Sub
 


Pick up & Concatenate a List of Email Addresses

Pick up and concatenate a list of Email addresses as a semi-colon delimited String (change 'Header' to a Header of your choice):

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


Format Column Ranges

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

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

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

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

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

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

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

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

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

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

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


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

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

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


Deleting Rows

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

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

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

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

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


Setting AutoFilter Criteria

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

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

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

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


Picking up List Data

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

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


Converting Text to Numbers

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

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

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


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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

    Application.ScreenUpdating = False
    Application.EnableEvents = False

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

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

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

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

End Sub
 


Converting Column Numbers to Letters

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

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

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

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

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


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

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

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

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

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

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

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


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

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

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


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

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

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


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

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

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

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

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

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


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

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

Private Sub RegExMatchTest()

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

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

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

' display the Item
MsgBox result

End Sub
 


Picking up a Range into a Variant Array

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

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

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

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


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

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

Option Explicit

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

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


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

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

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


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

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

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


How to Display what is AutoFiltered as Text

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

End Sub
 


Looping Worksheets By Array Of Sheet Names Or Code Names

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

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