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
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
These are some legacy Subroutines and Functions - you are free to modify this Code
mdlCoreSubroutines.bas
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
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
' Cells that are NOT Blank but act as if they are - 2 methods
' method 1, change to values
Public Sub RemovePusedoBlanks()
Columns("A:A").Value = Columns("A:A").Value
End Sub
' method 2, loop and change
' Alex Blakenburg
Sub RemoveAllBlanks()
Dim rngCol As Range
Dim rngData As Range
Set rngData = Range("A:A")
For Each rngCol In rngData.Columns
On Error Resume Next
rngCol.TextToColumns Destination:=rngCol, _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False, _
FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Next rngCol
End Sub
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)
If you want to use Formula in VBA then there are a number of ways that you can do this. The first way is by utilising the Application.WorksheetFunction() Function and the second way is by using the Sheet.Evaluate() Function. Here are some examples (change the Ranges below accordingly):
' Using EVALUATE() to count the unique items in a Range on a Sheet using the Code Module Sheet Name
Dim Result As Long
Result = Sheet1.Evaluate("=SUM(IFERROR(1/COUNTIF(A1:A100,A1:A100),0))")
MsgBox Result
' Using EVALUATE() to count the unique items in a Range on a Sheet using the Sheet Name in the current Workbook
Dim Result As Long
Result = ThisWorkbook.Sheets("Sheet1").Evaluate("=SUM(IFERROR(1/COUNTIF(A1:A100,A1:A100),0))")
MsgBox Result
' Using WORKSHEETFUNCTION() SUM a Range on a Sheet using the Code Module Sheet Name
Dim Result As Long
Result = Application.WorksheetFunction.Sum(Sheet1.Range("B1:B100"))
MsgBox Result
' Using WORKSHEETFUNCTION() SUM a Range on a Sheet using the the Sheet Name in the current Workbook
Dim Result As Long
Result = Application.WorksheetFunction.Sum(ThisWorkbook.Sheets("Sheet1").Range("B1:B100"))
MsgBox Result
' Using WORKSHEETFUNCTION() to count the number of occurances of the Name "Mark" within a Range on a Sheet using the Code Module Sheet Name
Dim Result As Long
Result = Application.WorksheetFunction.CountIf(Sheet1.Range("A1:A100"), "Mark")
MsgBox Result
If you have have ever wanted to work out how many Weeks you have until the Forecast consumes all of your Stock then you can use these Formula and example Workbook to do it. The first Formula added to Cell "E2" assumes that you have data in 2 Columns A & B, in Column A, an Index 1-13 starting in Cell "A2" and in Column B a set of random numbers starting in Cell "B2" down the range. This Formulas will tell you how many weeks before the cumulative sum of the random numbers exceeds a number in Cell "D2" ie. 150. BUT IN ROWS. The second Formula will do the same BUT IN COLUMNS which is nicer when using data values spanning the Columns. The second Fomula added to Cell "O2" assumes that you have data in 2 Rows from Cells "B2:I2" for the Index (or Weeks) and the random numbers in Cells "B3:I3". Download the example Workbook to see the Formula in action (2 examples - count of Rows or Columns before a cumulative target is exceeded and count of Rows and Columns of cumulative values under target)
' THE FIRST FORMULA - How Many Weeks but in ROWS
=MATCH(D2,SUBTOTAL(9,OFFSET(B2,,,ROW(B2:B14)-ROW(B2))),1)
' THE SECOND FORMULA - How Many Weeks but in COLUMNS
=MATCH(N2,SUBTOTAL(9,OFFSET(B3,,,,COLUMN(B3:I3)-COLUMN(B3))),1)
' A Complex Formula that uses the data on a Forecast Sheet looking up the Stock and then working out how many weeks it will last
' ie. Stock Weeks on Hand - see Stock in Hand (Volatile Formula).xlsx download example
' Caution INDIRECT() is a VOLATILE function and will slow down Excel for large calculations
' I also have an INDIRECT REPLACEMENT function in the form of INDEX() - see the downloads below
=IFERROR(MATCH(INDEX('Stock on Hand'!C:C,MATCH($A5,'Stock on Hand'!A:A,0)),SUBTOTAL(9,OFFSET(INDIRECT(ADDRESS(ROW(),MATCH('Stock on Hand'!$A$1&"",FC!A$4:DC$4,0))),,,,COLUMN(INDIRECT(ADDRESS(ROW(),MATCH('Stock on Hand'!$A$1&"",FC!A$4:DC$4,0))&":"&ADDRESS(ROW(),MATCH("52.2023",FC!A$4:DC$4,0))))-COLUMN(INDIRECT(ADDRESS(ROW(),MATCH('Stock on Hand'!$A$1&"",FC!A$4:DC$4,0)))))),1),0)
' INDIRECT REPLACEMENT USING INDEX() - see Stock in Hand (Non-volatile Formula).xlsx download example
=IFERROR(MATCH(INDEX('Stock on Hand'!C:C,MATCH(FC!A5,'Stock on Hand'!A:A,0)),SUBTOTAL(9,OFFSET(INDEX($A:$DC,ROW(),MATCH('Stock on Hand'!$A$1&"",FC!A$4:DC$4,0)),,,,COLUMN(INDEX($A:$DC,ROW(),MATCH('Stock on Hand'!$A$1&"",FC!A$4:DC$4,0)):INDEX($A:$DC,ROW(),COLUMN($DC$1)))-COLUMN(INDEX($A:$DC,ROW(),MATCH('Stock on Hand'!$A$1&"",FC!A$4:DC$4,0))))),1),0)
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
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"
There are many ways to delete duplicate values in a Column or in a Range anywhere on a Sheet using VBA - here are a few examples:
' delete any duplicate Rows for Column A which allows us to ignore the Header (1 Column)
With ActiveSheet
.Range("A1").CurrentRegion.Offset(1, 0).RemoveDuplicates (Array(1))
End With
' or... (1 Column)
ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0).RemoveDuplicates (Array(1))
' if we don't have a Header we can just do this
ActiveSheet.Range("A1").CurrentRegion.RemoveDuplicates (Array(1))
' for multiple Columns with Duplicates that start in A5 to B13 we can use VBA like this - notice we have the option to include a Header in our Range
ActiveSheet.Range("$A$5:$B$13").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
' make it dynamic using a Variable - notice we have the option to include a Header in our Range
' this method also works for Blank Rows in the entire Column so you can check and remove duplicates even after empty Rows!
Dim LastRow As Long
LastRow = ActiveSheet.Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row
ActiveSheet.Range("$A$5:$B$" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
There are many ways to wait or pause for durations using VBA:
' pause for 5 seconds:
' Wait does not accept delays of less than 1 second
Application.Wait (Now + TimeValue("0:00:05"))
' pause execution until a specific time ie. this will pause a macro until 9am
Application.Wait "09:00:00"
' My Favourite - a Pause Subroutine that you use like this Pause 100 (pause for 100 Milliseconds)
#If VBA7 Then
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
Private Declare Function GetTickCount Lib "kernel32" () As Long
#End If
Private Sub Pause(ByVal Milliseconds As Long)
Dim TickCount As Long: TickCount = GetTickCount
Do: DoEvents: Loop Until TickCount + Milliseconds < GetTickCount
End Sub
When creating certain types of Pivot Tables, you may not want a user to be able to Filter or Sort by a specific Field. So to hide a Drop-down on a Pivot Field you can employ the following Code (add the Code to a Standard Code Module and then change the Pivot Table to your Pivot Table Name and the Field to your Field Name):
' use this to hide/disable a Drop-down in a Pivot Table by the Field Name
Private Sub DisableKeyFigureSelection()
Dim pt As PivotTable
Dim pf As PivotField
On Error Resume Next
Set pt = ActiveSheet.PivotTables("PivotTable1")
For Each pf In pt.PivotFields
If pf.Name = "Key Figure" Then pf.EnableItemSelection = False
Next pf
On Error GoTo 0
End Sub
A great technique to fix issues when the Last Cell cannot be reset, found here:
https://superuser.com/questions/1349521/deleting-rows-in-excel-doesnt-reset-last-cell-used-range
' Open Excel. Go into VBA Code Editor. View Immediate Window and Type the parts with the ? prefix
? activesheet.name
[shows sheet name]
? activesheet.usedrange.address
$A:$AH
activesheet.usedrange.rowheight = 23
? activesheet.usedrange.address
$A$11:$AH$1493
And the best that I have found using VBA can be found here:
https://www.mrexcel.com/board/threads/reset-last-cell-on-worksheet.73426/
Dim LastUsedRow As Long, LastUsedCol As Long
LastUsedRow = Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
LastUsedCol = Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column
Rows(LastUsedRow + 1).Resize(Rows.Count - LastUsedRow).Delete
Columns(LastUsedCol + 1).Resize(, Columns.Count - LastUsedCol).Delete
ActiveSheet.UsedRange
Range(ActiveCell, ActiveCell.SpecialCells(xlCellTypeLastCell)).Select
My version to also Scroll Up and Back to reset the Excel Window. You can easily modify this to loop all Worksheets:
Dim LastUsedRow As Long
Dim LastUsedCol As Long
ThisWorkbook.Sheets("Sheet1").Select
ThisWorkbook.Sheets("Sheet1").Range("A1").Activate
LastUsedRow = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
LastUsedCol = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column
With ActiveSheet
.Rows(LastUsedRow + 1).Resize(.Rows.Count - LastUsedRow).Delete
.Columns(LastUsedCol + 1).Resize(, .Columns.Count - LastUsedCol).Delete
.UsedRange
.Range(ActiveCell, ActiveCell.SpecialCells(xlCellTypeLastCell)).Select
.Range("A1").Activate
.Range("A1").Select
End With
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
To use a Range ie. 0 to 5 and return the 50% Position you can use the ScaleBetween Function below:
' Cell "L13" = 0|5 or 10|100 etc.
Sub Constrain()
Dim BetweenStart As Long
Dim BetweenEnd As Long
Dim Position As Long
BetweenStart = Split(ActiveSheet.Range("L13").Value2, "|")(0)
BetweenEnd = Split(ActiveSheet.Range("L13").Value2, "|")(1)
Position = 50
MsgBox ScaleBetween(Position, BetweenStart, BetweenEnd, 0, 100)
End Sub
Private Function ScaleBetween(ByRef Unscaled As Variant, ByRef First As Variant, ByRef Last As Variant, ByRef Min As Variant, ByRef Max As Variant) As Variant
ScaleBetween = (Last - First) * (Unscaled - Min) / (Max - Min) + First
End Function
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
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
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
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
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)]
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
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
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
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
Sometimes you want to clear all of the Autofilters or Filtered Fields in a Table. You can do this by using the Code below regardless of whether or not the Sheet containing the Table is selected:
' ListObjects(1) is the first Table on a Sheet called Calculations, you can also use the Table Name ie. ("Calc")
' - this Code works regardless of whether or not the Sheet containing the Table is selected
Dim FilteredTable As ListObject
Set FilteredTable = Calculations.ListObjects(1)
FilteredTable.AutoFilter.ShowAllData
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
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
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
Here are methods to get the last Row or first/last available Row in a Column Range or on the Active Worksheet. Please note: there are more methods of finding the Last Row using VBA if you scroll down a little further:
' last Row on a Worksheet using Special Cells - this may or may not always return the correct Row!
Sheet1.Cells.SpecialCells(xlCellTypeLastCell).Row
' 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
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)
Here are some methods to get the last Row in a variety of different ways:
' finding the last Row on the Active Sheet for a Column ie. "C" ** this is one of my favourite methods as I commonly will be using Code on a Sheet where say the first Column will always be the default SKU list that I want to check
Dim LastRow As Long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
' 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
' a function to return the Last Row from a passed Range of Columns. Please note: for this example, you have to pass the Column Range as "A1:F1" not "A:F" or "A1:F100" as it uses Offset(). You do not have to have the Sheet selected to return the GetLastRow
' MsgBox GetLastRow(Sheet1.Range("A1:C1"))
Private Function GetLastRow(ByVal RowRange As Range) As Long
Dim X As Long
Dim Y As Long
Dim Z As Long
For X = 1 To RowRange.Columns.Count
Y = RowRange.Columns(X).Offset(ActiveSheet.Rows.Count - RowRange.Row, 1).End(xlUp).Row
If Y > Z Then Z = Y
Next X
GetLastRow = Z
End Function
' this one allows you to use "A:C" as it uses Cells(). You do not have to have the Sheet selected to return the GetLastRow
' MsgBox GetLastRow(Sheet1.Range("A:C"))
Private Function GetLastRow(ByVal RowRange As Range) As Long
Dim X As Long
Dim Y As Long
Dim Z As Long
For X = 1 To RowRange.Columns.Count
Y = RowRange.Columns(X).Cells(ActiveSheet.Rows.Count - RowRange.Row, 1).End(xlUp).Row
If Y > Z Then Z = Y
Next X
GetLastRow = Z
End Function
To Refresh all Pivot Tables (includes data connections, Tables etc.):
ActiveWorkbook.RefreshAll
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
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
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)")
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
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"
' or use the Function below with a Call like this:
If WorksheetExists("Commission paid monthly") Then MsgBox "Sheet exists" Else MsgBox "Sheet doesn't exist"
Function WorksheetExists(WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WorksheetName).Name = WorksheetName
On Error GoTo 0
End Function
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()
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
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")
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
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
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
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
Need a fast Array Sort to sort a lists Ascending/Descending? Check out this VBA that has 4 Buttons linked to each Column to Sort the Range B11:e50010 and Sorting 5000 Rows:
Option Explicit
Option Base 1
Option Compare Text
Private Const SortRange As String = "b11:e50010"
Private Const RowsToSort As Long = 50000
Public Sub SortByName()
Dim JaggedArray() As Variant
JaggedArray = Range(SortRange)
JaggedSort JaggedArray, 1, RowsToSort, 4, 1, xlAscending ' xlAscending/xlDescending or use a Defined Name/Named Range [sort_direction]
Range(SortRange) = JaggedArray
End Sub
Public Sub SortByGUID()
Dim JaggedArray() As Variant
JaggedArray = Range(SortRange)
JaggedSort JaggedArray, 1, RowsToSort, 4, 2, xlAscending ' xlAscending/xlDescending or use a Defined Name/Named Range [sort_direction]
Range(SortRange) = JaggedArray
End Sub
Public Sub SortByDate()
Dim JaggedArray() As Variant
JaggedArray = Range(SortRange)
JaggedSort JaggedArray, 1, RowsToSort, 4, 3, xlAscending ' xlAscending/xlDescending or use a Defined Name/Named Range [sort_direction]
Range(SortRange) = JaggedArray
End Sub
Public Sub SortByNumber()
Dim JaggedArray() As Variant
JaggedArray = Range(SortRange)
JaggedSort JaggedArray, 1, RowsToSort, 4, 4, xlAscending ' xlAscending/xlDescending or use a Defined Name/Named Range [sort_direction]
Range(SortRange) = JaggedArray
End Sub
' JaggedSort, fast sort by any Column for a Jagged Worksheet Array
Private Sub JaggedSort(ByRef JaggedArray As Variant, _
ByVal RowsFrom As Long, _
ByVal RowsTo As Long, _
ByVal NumberOfColumns As Integer, _
ByVal MySortColumn As Integer, _
Optional MySortDirection As XlSortOrder = xlAscending)
Dim vntA As Variant
Dim vntB As Variant
Dim lngX As Long
Dim lngY As Long
Dim lngZ As Long
lngY = RowsTo: lngX = RowsFrom
vntA = JaggedArray(Int((RowsFrom + RowsTo) / 2), MySortColumn)
Do While lngX <= lngY
If MySortDirection = xlAscending Then
Do While JaggedArray(lngX, MySortColumn) < vntA: lngX = lngX + 1: Loop
Else
Do While JaggedArray(lngX, MySortColumn) > vntA: lngX = lngX + 1: Loop
End If
If MySortDirection = xlAscending Then
Do While JaggedArray(lngY, MySortColumn) > vntA: lngY = lngY - 1: Loop
Else
Do While JaggedArray(lngY, MySortColumn) < vntA: lngY = lngY - 1: Loop
End If
If lngX <= lngY Then
For lngZ = 1 To NumberOfColumns
vntB = JaggedArray(lngX, lngZ)
JaggedArray(lngX, lngZ) = JaggedArray(lngY, lngZ)
JaggedArray(lngY, lngZ) = vntB
Next
lngX = lngX + 1: lngY = lngY - 1
End If
Loop
If RowsFrom < lngY Then JaggedSort JaggedArray, RowsFrom, lngY, NumberOfColumns, MySortColumn, MySortDirection
If lngX < RowsTo Then JaggedSort JaggedArray, lngX, RowsTo, NumberOfColumns, MySortColumn, MySortDirection
End Sub
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
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":
Sorting a Range using the first Column is easy, for example suppose you want to Sort a Range with/Without an Autofilter in Sheet1, by Column 1 Ascending, then just Set:
MyDefinedName to Sheet1.Range("A1") when passing the first Parameter
' 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
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
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 and concatenate a list of Email addresses or a List of Product Codes 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), "; ")
' with Sheet1, Find and then Concatenate a list of Material Codes using a semi-colon and output the result in Cell "A1"
With Sheet1
.Range("A1").Value2 = Join(Application.Transpose(Cells.Find("Material", , xlValues, xlWhole, xlByRows, xlNext, True).CurrentRegion.Offset(1, 0).Resize( _
Cells.Find("Material", , xlValues, xlWhole, xlByRows, xlNext, True).CurrentRegion.Rows.Count - 1, 1).Value), "; ")
End With
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
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
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
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
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))
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
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
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")
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
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
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)
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")
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
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))
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
Here is the Code to get the correct Filepath for both local files and files on SharePoint. This Code is useful when using ODBC to pull data from the Workbook or another Workbook on SharePoint and for pulling data from other Workbooks - I did not write this Code:
' use like GetLocalFile(ThisWorkbook)
Function GetLocalFile(wb As Workbook) As String
' Set default return
GetLocalFile = wb.FullName
Const HKEY_CURRENT_USER = &H80000001
Dim strValue As String
Dim objReg As Object: Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Dim strRegPath As String: strRegPath = "Software\SyncEngines\Providers\OneDrive\"
Dim arrSubKeys() As Variant
objReg.EnumKey HKEY_CURRENT_USER, strRegPath, arrSubKeys
Dim varKey As Variant
For Each varKey In arrSubKeys
' check if this key has a value named "UrlNamespace", and save the value to strValue
objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "UrlNamespace", strValue
' If the namespace is in FullName, then we know we have a URL and need to get the path on disk
If InStr(wb.FullName, strValue) > 0 Then
Dim strTemp As String
Dim strCID As String
Dim strMountpoint As String
' Get the mount point for OneDrive
objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "MountPoint", strMountpoint
' Get the CID
objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "CID", strCID
' Add a slash, if the CID returned something
If strCID <> vbNullString Then
strCID = "/" & strCID
End If
' strip off the namespace and CID - modified by Mark Kubiszyn to include a minus 1
strTemp = Right(wb.FullName, Len(wb.FullName) - (Len(strValue & strCID) - 1))
' replace all forward slashes with backslashes
GetLocalFile = strMountpoint & Replace(strTemp, "/", "\")
Exit Function
End If
Next
End Function
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
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
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
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
It also follows, then, that one could use Code such as this to identify the Next Non-prime - remember we don't want to see Even Numbers so they are skipped as well as Prime Numbers:
Function NextNonPrime(ByVal Number As Long) As Long
Start:
Number = Number + 1
While IsPrime(Number)
Number = Number + 1
Wend
If Number Mod 2 = 0 Then GoTo Start
NextNonPrime = Number
End Function
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:
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
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
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
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
Here is Code to Copy some Text from Cell "A1" to the Clipboard and the Paste it back into the Worksheet Active Cell:
Option Explicit
' in the VBA editor, go to Tools, References, and set a reference to the "Microsoft Forms 2.0 Object Library"
' local vars
Private objData As DataObject
Private strClipboard As String
' CopyToClipboard
Public Sub CopyToClipboard()
strClipboard = Range("A1").Value
Set objData = New DataObject
objData.SetText strClipboard
objData.PutInClipboard
End Sub
' PasteFromClipboard
Public Sub PasteFromClipboard()
objData.GetFromClipboard
strClipboard = objData.GetText
ActiveCell.Value2 = strClipboard
End Sub
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
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
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
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
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
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
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
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
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
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
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]"
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
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
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
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
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
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
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
Here is a Formula using latest Excel to Generate a List of 100 Random Numbers without Repeats (Select 100 Rows and Paste Formula into first Cell and enter using CTRL+SHIFT+ENTER):
' array Formula - brakets will be added by Excel when you press CTRL+SHIFT+ENTER
=SORTBY(SEQUENCE(100),RANDARRAY(100))
Here is a little piece of Code that you can add to a Worksheet Code Module to prevent deletion of Columns, Rows, Cells, Cell content etc. in a Worksheet:
' ## Worksheet_Change, used to preserve data integrity ie. undo any removed Cell data
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = True
If Not Intersect(Target, Me.Range("B:B")) Is Nothing Then
On Error GoTo Catch
Dim UndoAction As Boolean
With Application
.EnableEvents = False
Dim CellRange As Range
For Each CellRange In Target
If Len(Trim$(CellRange.Value)) = 0 Then UndoAction = True: Exit For
Next CellRange
If UndoAction Then .Undo
.EnableEvents = True
End With
Try:
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
Catch:
Resume Try
End If
End Sub
Here is the Worksheet_PivotTableUpdate() Event that can be added into a Worksheet Code Module to Slice a Pivot Table Values Area. This Code allows you to link a list of Fields Names being the same as your Values Fields that you have added into your own Pivot Table area (bottom right) with a Slicer so that when you Slice the Items, the Columns for the Values Area Fields will be hidden or displayed:
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
On Error GoTo Catch
' alows Slicing/Filtering of the Values area of a Pivot Table via the use of a Pivot Table with a similar list of Field Names
Dim LinkedPivotTable As PivotTable
Dim PivotTableToFilter As PivotTable
Dim LinkedFields As PivotField
Dim PivotFieldsToFilter As PivotField
Dim LinkedItems As PivotItem
' Pivot Table Field/Column, used to maintain a list of Field Names for the Slicer. set this to your linked Pivot Table
Set LinkedPivotTable = ActiveSheet.PivotTables("Columns")
' the Name of the linked Field/Column containing the list. set this to your linked Pivot Table Field/Column
Set LinkedFields = LinkedPivotTable.PivotFields("Column")
' Pivot Table to be controlled by the Slicer with the list of Field Names. set this to your Pivot Table
Set PivotTableToFilter = ActiveSheet.PivotTables("Test")
Application.EnableEvents = False
If Target.Name = LinkedPivotTable.Name Then
For Each LinkedItems In LinkedFields.PivotItems
For Each PivotFieldsToFilter In PivotTableToFilter.PivotFields
If PivotFieldsToFilter.Name = LinkedItems.Name Then
If LinkedItems.Visible = False Then
On Error Resume Next
' set this up to use any suffix for any renaming of the Field
PivotTableToFilter.PivotFields("Sum of " & PivotFieldsToFilter.Name).Orientation = xlHidden
On Error GoTo Catch
Else
On Error Resume Next
' set this up to use any suffix for any renaming of the Field and what kind of calculation that you want the Filed to perform
PivotTableToFilter.AddDataField PivotTableToFilter.PivotFields(PivotFieldsToFilter.Name), "Sum of " & PivotFieldsToFilter.Name, xlSum
On Error GoTo Catch
End If
End If
Next PivotFieldsToFilter
Next LinkedItems
End If
Catch:
Application.EnableEvents = True
End Sub
Here is a little piece of Code that will unfilter AutoFiltered Ranges and Tables Filtered by Headers or Slicers for all Visible Sheets in a Workbook:
Private Sub Unfilter()
' normal autofilters on visible Sheets
Dim TheSheet As Worksheet
On Error Resume Next
For Each TheSheet In ThisWorkbook.Worksheets
If TheSheet.Visible Then TheSheet.ShowAllData
Next TheSheet
On Error GoTo 0
' unfilter tables
Dim TheTable As ListObject
For Each TheSheet In ThisWorkbook.Worksheets
If TheSheet.Visible Then
For Each TheTable In TheSheet.ListObjects
TheTable.AutoFilter.ShowAllData
Next TheTable
End If
Next TheSheet
End Sub
Here is a little piece of Code that will Delete Rows in the Activesheet by a List containing Criteria in another Sheet or Keeps Rows that are in the List in another Sheet. Obviously pass the Range Addresses to make these dynamic. Oh' and add in LookIn:=xlValues to the .Find() function if you are examining Formula and not Values:
' Delete. add in LookIn:=xlValues to the .Find() function if you are examining Formula and not Values
Sub DeleteRowsByListCriteria()
Dim rngFound As Range
Dim rngToDelete As Range
Dim strFirstAddress As String
Dim varList As Variant
Dim lngCounter As Long
varList = Range("Sheet2!A1:A10").Value
For lngCounter = LBound(varList) To UBound(varList)
With ActiveSheet.Range("A:A")
Set rngFound = .Find( _
What:=varList(lngCounter, 1), _
Lookat:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True _
)
If Not rngFound Is Nothing Then
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
strFirstAddress = rngFound.Address
Set rngFound = .FindNext(After:=rngFound)
Do Until rngFound.Address = strFirstAddress
Set rngToDelete = Application.Union(rngToDelete, rngFound)
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngCounter
If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
End Sub
' Keep. add in LookIn:=xlValues to the .Find() function if you are examining Formula and not Values
Sub DeleteRowsNotInListCriteria()
Dim rngFound As Range
Dim rngToDelete As Range
Dim strFirstAddress As String
Dim varList As Variant
Dim lngCounter As Long
varList = Range("Sheet2!A1:A10").Value
For lngCounter = LBound(varList) To UBound(varList)
With ActiveSheet.Range("A2:A10")
Set rngFound = .Find( _
What:=varList(lngCounter, 1), _
Lookat:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True _
)
If Not rngFound Is Nothing Then
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
strFirstAddress = rngFound.Address
Set rngFound = .FindNext(After:=rngFound)
Do Until rngFound.Address = strFirstAddress
Set rngToDelete = Application.Union(rngToDelete, rngFound)
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngCounter
Dim rngDiff As Range
Set rngDiff = Difference(Range("A2:A10"), rngToDelete)
If Not rngDiff Is Nothing Then rngDiff.EntireRow.Delete
End Sub
Private Function Difference(Range1 As Range, Range2 As Range) As Range
Dim rngUnion As Range
Dim rngIntersect As Range
Dim varFormulas As Variant
If Range1 Is Nothing Then
Set Difference = Range2
ElseIf Range2 Is Nothing Then
Set Difference = Range1
ElseIf Range1 Is Nothing And Range2 Is Nothing Then
Set Difference = Nothing
Else
Set rngUnion = Union(Range1, Range2)
Set rngIntersect = Intersect(Range1, Range2)
If rngIntersect Is Nothing Then
Set Difference = rngUnion
Else
varFormulas = rngUnion.Formula
rngUnion.Value = 0
rngIntersect.ClearContents
Set Difference = rngUnion.SpecialCells(xlCellTypeConstants)
rngUnion.Formula = varFormulas
End If
End If
End Function
This Function takes a Sheet ie. ActiveSheet, a String ie. a Header, say "Name" and the number of contiguoug Columns to pick up and it returns the Set Range ie. Range("A1:B1001"). You can use it to pick up Jagged Data. Combine it with my UnionSingleRangesByColumns() Function to Join Multiple, Jagged Arrays. You can download 2 Examples in my Archive - see the links at the top of this Page
' Address usage
MsgBox SetRange(ActiveSheet, "Name", 2).Address
' Array usage
Dim vntData As Variant
vntData = SetRange(ActiveSheet, "Name", 2).Cells
Public Function SetRange(ByVal Sheet As Worksheet, ByVal Criteria As String, _
Optional NumberOfColumns As Integer = 1, _
Optional FindDefinedName As Boolean = False) As Range
Dim objName As Name
Dim rngCell As Range
With Sheet
If FindDefinedName Then
For Each objName In Names
If objName.Name Like Criteria Then
Set rngCell = .Range(Criteria): Exit For
End If
Next objName
If Not rngCell Is Nothing Then
Set SetRange = .Range(rngCell.Address & ":" & Split(.Cells(, rngCell.Column + NumberOfColumns - 1).Address, "$")(1) & _
.Range(Split(.Cells(, rngCell.Column).Address, "$")(1) & .Rows.Count).End(xlUp).Row).Cells
End If
Else
Set rngCell = .Cells.Find(Criteria, .Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext, True)
If Not rngCell Is Nothing Then
Set SetRange = .Range(rngCell.Address & ":" & Split(.Cells(, rngCell.Column + NumberOfColumns - 1).Address, "$")(1) & _
.Range(Split(.Cells(, rngCell.Column).Address, "$")(1) & .Rows.Count).End(xlUp).Row).Cells
End If
End If
End With
End Function
This Subroutine will Merge the Styles in your WOrkbook into another WOrkbook - ensure that you have the Workbook that you want to Merge the Styles into and then run the Macro. The StyleKiller() Subroutine will delete any non-inbuilt Styles in a Workbook
Public Sub MergeStyles__IntoAnotherWorkbook()
' // merge styles from this Workbook into another
Application.DisplayAlerts = False
ActiveWorkbook.Styles.Merge Workbook:=Workbooks(ThisWorkbook.Name)
Application.DisplayAlerts = True
End Sub
Public Sub StyleKiller()
' posted on www.mrexcel.com forum by delaneyjm
Dim styT As Style
Dim intRet As Integer
On Error Resume Next
For Each styT In ActiveWorkbook.Styles
If Not styT.BuiltIn Then
If styT.Name <> "1" Then styT.Delete
End If
Next styT
End Sub
You can locate and use the background image that a user has embedded into an Excel Worksheet by renaming the file to .ZIP and then going into the Media Folder of the Zip Archive ie. C:\Archive\Working\Software\Carlsberg\CVC Generator Changes\test.zip\xl\media
The image will be in there named as image1.png for example. Copy the Image to another location and there you have it, simply add as the Background Image to your own Project...
This Function will return the Index of a Cell within a Range on a Worksheet ie. consider "A1:C1" then "B1" would be 2, consider "A1:D6" then "A6" would equal 21
It uses psuedo code like this: (fx) = IndexCell.Row - 1 * RangeCells.Columns + IndexCell.Column - the absolute position within a Sheet Rows * Columns - Columns offset
Public Sub GetIndex()
MsgBox IndexOfRangeCellWithinRange(ActiveSheet.Range("G6:I13"), ActiveSheet.Range("H10"))
MsgBox IndexOfRangeCellWithinRange(ActiveSheet.Range("B5:E5"), ActiveSheet.Range("D5"))
End Sub
' IndexOfRangeCellWithinRange, returns the Index of a Cell within a Range ie. consider "A1:D6" then "A6" would equal 21
' Debug.Print IndexOfRangeCellWithinRange(ActiveSheet.Range("G6:I13"), ActiveSheet.Range("H10"))
' = 14
Public Function IndexOfRangeCellWithinRange(ByVal RangeCells As Range, ByVal IndexCell As Range) As Long
IndexOfRangeCellWithinRange = ((IndexCell.Row - 1) * RangeCells.Columns.Count + IndexCell.Column _
- ((RangeCells.Cells(1, 1).Row - 1) * RangeCells.Columns.Count)) _
- (RangeCells.Cells(1, 1).Column - 1)
End Function
This Function will return a Range that omits the intersecting Range
Use it something like this, where I pass a Range of Cells and then a single Cell that I don't want to render: InverseIntersect(RolloverRange, RolloverCell).Interior.Color = RGB(138, 161, 127) will colour only the Cells in the first Range that don't match the Cells in the second
' InverseIntersect, returns the inverse of a Range given two Ranges
Public Function InverseIntersect(ByRef rngA As Range, ByRef rngB As Range) As Range
Dim rCell As Range
Dim rngC As Range
For Each rCell In Union(rngA, rngB)
If Intersect(rCell, rngA, rngB) Is Nothing Then
If rngC Is Nothing Then
Set rngC = rCell
Else
Set rngC = Union(rngC, rCell)
End If
End If
Next
Set InverseIntersect = rngC
End Function
This technique, ususally used to add a dummy Tooltip to a Shape can use the process to let a user go straight into the VBA/VBE Editor to view your Code
' add all of this code to a standard Code Module
' add a Shape and name it Menu. then run the AddTooltip Subroutine. Now click on the Shape to view your Code
Private Sub AddTooltip()
ActiveSheet.Shapes("Menu").Parent.Hyperlinks.Add ActiveSheet.Shapes("Menu"), "", "BurgerMenuClick", ScreenTip:="Click for menu"
End Sub
Public Sub BurgerMenuClick()
MsgBox "Hello World!"
End Sub
Use the following VBA Code to change Date Formats (sometimes caused by Citrix for example even though your locale settings for both Excel and PC (Windows 11) are set correctly. Sometimes I have found that you may need to do this more than once to ensure compliance. "J7" is the start Cell underneath your Column Header
Dim lngLastRow As Long
lngLastRow = ActiveSheet.Cells(ActiveSheet.rows.Count, "A").End(xlUp).Row
Range("J7:J" & lngLastRow).TextToColumns FieldInfo:=Array(0, xlDMYFormat)
Range("J7:J" & lngLastRow).NumberFormat = "dd/mm/yyyy;@"
Use the following VBA Code to check for a Valid Folder
' FolderExists, returns True for a valid Folder or False
Public Function FolderExists(ByVal FolderPath As String) As Boolean
On Error Resume Next
FolderExists = ((GetAttr(FolderPath) And vbDirectory) = vbDirectory)
On Error GoTo 0
End Function
Use the following VBA Code to Extract & Sort Unique Items from Columns of Data or Download 2ColumnsExtractUniqueAndSort.xlsx
' with numbers and letters from A2:B19 add this formula to Cell C1
=SORT(UNIQUE(INDEX($A$2:$B$19,MOD(SEQUENCE(2*18)-1,18)+1,INT(SEQUENCE(2*18,,18)/18))))
Use the following VBA Code to Count and COUNTIF the Number of times some Criteria is in a Range from "B2:E5" with Headers the word "fail":
' a count of appearances ie. 0, 1, 2 etc.
=COUNTIF(B3:E3,"*fail*")
' acting on a count of appearances ie. "fail is in there somewhere" or ""
=IF(COUNTIF(B3:E3,"*fail*")>0,"fail is in there somewhere","")
Use the following to check whether a Selection or Selected Range in a Worksheet is Cells only, False := not single Cells, True := single Cells. Please Note: if you want to check whether a Selection or the Selected Range is Completely Within a Bounded Range then scroll down to read more examples:
' SelectionIsCells, check whether the Selection is Cells only, False := not single Cells, True := single Cells
' 1. checks for a Range definition
' 2. checks for a single Selection in case of multiple Selections
' 3. checks for only Column or Row Selection
Public Function SelectionIsCells(ByVal SelectionRange As Range) As Boolean
If TypeOf Selection Is Range Then
If Selection.Areas.Count = 1 Then
If Selection.Address = Selection.EntireColumn.Address Or Selection.Address = Selection.EntireRow.Address Then _
SelectionIsCells = False Else SelectionIsCells = True
End If
End If
End Function
Use the following to check whether a Selection or the Selected Range is Overlapping a Bounded Range, False := it is not within, True := it is within:
' SelectionIsOverlappingBoundedRange, checks whether the Selection is overlapping a bounded Range (having bounds or limits), False := it is not within, True := it is within
' Please Note: this will allow overlaps from one Range to Another and will return True
Public Function SelectionIsOverlappingBoundedRange(ByVal SelectionRange As Range, ByVal BoundedRange As Range) As Boolean
If Intersect(SelectionRange, BoundedRange) Is Nothing Then SelectionIsOverlappingBoundedRange = False Else SelectionIsOverlappingBoundedRange = True
End Function
Use the following to check whether a Selection or the Selected Range is Completely Within a Bounded Range, False := it is not within, True := it is within:
' SelectionIsWithinBoundedRange, checks whether the Selection is completely within a bounded Range (having bounds or limits), False := it is not within, True := it is within
Public Function SelectionIsWithinBoundedRange(ByVal SelectionRange As Range, ByVal BoundedRange As Range) As Boolean
Dim Valid As Range: Set Valid = Application.Intersect(SelectionRange, BoundedRange)
If Not Valid Is Nothing Then If Not Application.Intersect(SelectionRange, BoundedRange).Address = Selection.Address Then SelectionIsWithinBoundedRange = False Else SelectionIsWithinBoundedRange = True
End Function
Use the following to change Table Formula into Values:
ActiveSheet.ListObjects("CassandraTable").DataBodyRange.Formula = ActiveSheet.ListObjects("CassandraTable").DataBodyRange.Value2
Use the following to Hide Green Triangles for Error Checking:
' hides common Error warnings and inconsistent Formula
Public Sub HideWarningTriangles()
Dim rngCell As Range, bError As Byte
For Each rngCell In Selection.Cells
For bError = 1 To 4
With rngCell
If .Errors.Item(bError).Value Then
.Errors.Item(bError).Ignore = True
End If
End With
Next bError
Next rngCell
' use this to hide specific Error Triangles if you do not just want the above
Application.ErrorCheckingOptions.InconsistentFormula = False
End Sub
Use the following to Fade a Shape or SVG Image Shape In:
Public Sub FadeShapeIn()
Dim TweenTransparency As Long
Dim TweenTransparencyTimer As Double
Dim TweenTransparencyStart As Double
Dim TweenTransparencyStep As Long
TweenTransparencyTimer = 0.02
TweenTransparencyStep = -5
With Sheet1.Shapes("disc1")
.Visible = True
For TweenTransparency = 100 To 1 Step TweenTransparencyStep
.Fill.Transparency = TweenTransparency / 100
TweenTransparencyStart = Timer
Do
DoEvents
Loop While Timer - TweenTransparencyStart < TweenTransparencyTimer
Next TweenTransparency
End With
End Sub
Use the following to Fade a Shape or SVG Image Shape Out:
Public Sub FadeShapeOut()
Dim TweenTransparency As Long
Dim TweenTransparencyTimer As Double
Dim TweenTransparencyStart As Double
Dim TweenTransparencyStep As Long
TweenTransparencyTimer = 0.02
TweenTransparencyStep = 5
With Sheet1.Shapes("disc1")
For TweenTransparency = 1 To 100 Step TweenTransparencyStep
.Fill.Transparency = TweenTransparency / 100
TweenTransparencyStart = Timer
Do
DoEvents
Loop While Timer - TweenTransparencyStart < TweenTransparencyTimer
Next TweenTransparency
.Visible = False
End With
End Sub