Archive for the ‘Excel VBA Function’ Category
Usually in the sequential database system, we can SUM only unique values in table column by adding all the values from SELECT DISTINCT query result only.
Based on the same principle, we can also create a simple VBA function in Microsoft Excel by adding the values only available in a collection of unique values we have created before hand.
Public Function DISTINCTSUM(Rg As range)
Dim rCell As range
Dim cCells As New Collection
Dim vValue As Variant
' create a unique no duplicate value collection
For Each rCell In Rg
On Error Resume Next
cCells.Add rCell.Value, CStr(rCell.Value)
Next rCell
' sum all the data in previous collection
For Each vValue In cCells
DISTINCTSUM = vValue + DISTINCTSUM
Next vValue
Set cCells = Nothing
End Function
In here, first we create a Collection object that contains unique values only. Only then will we loop throught the collection and add up all the values stored there to get the DISTINCT SUM value.
Now we can call the above DISCTINCTSUM formula directly from Excel formula bar to sum only the unique or disctinct values in some range of cells, with the cell range as parameter.
=distinctsum(D4:D8)
Will sum all the unique values in range of D4 until D8. This is really helpful if we have a lot of duplicate data that we don’t want to count.
The other way around to get the sum of unique/distinct values in Excel is using Pivot Table.
Create a Pivot Table, then drop the column containing duplicate values in the Row fields area. Excel will then automatically filtered all the values and remove any duplicate values in that column. Later on, simply SUM all the data in the row fields to get the distinct sum.
The final result will be the same, but we don’t want to create a Pivot Table for every column we wanna sum, right?
Another way to get a list of unique values is to use the Advanced Filter feature. In advanced filtering options, check the option Copy to another location, and Unique records only option. Then select the cell where we want to put the unique values.
Easier to do compare to Pivot Table, but we still don’t have the flexibility of the previous DISTINCTSUM macro.
Ever want to paste some data into new empty cell after the last cell with data in certain column? Then take a look at this simple macro.
'first, select cell in the first row of that column, like A1, K1, etc
Range("A1").Select
'move to the last cell with data
Selection.End(xlDown).Select
'move to one row below it
ActiveCell.Offset(1, 0).Select
'paste the copied data in there
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Simple isn’t it? Simple code, but will help us a lot each time we wanna move the active cell into one cell below the last cell contained any kind of data, in the same column.
One requirement needed to use this simple excel vba macro, first we need to select the first cell in the same column where we wanna do the selection.
Let say we want to find position of cell containing the minimum/maximum value in current/active Excel worksheet, and then after we found the cell, we will change the cell format to make it stand out before other cells.
The logic is simple, we just need to use Excel MIN function to find the minimum/maximum value on the worksheet, and then using Excel FIND function we will find which cell contain that minimum/ maximum value.
Excel VBA macro implementation of the algorithm above will look like below, change code Application.Min(oRg) into Application.Max(oRg) to find the maximum value instead of minimum value.
Sub FindMinValue()
Dim oRg As Range, iMin As Variant
Set oRg = Cells
'Finding the minimum value
iMin = Application.Min(oRg)
'Select cell containing the min value
oRg.Find(What:=iMin, _
After:=oRg.Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False _
).Select
'Change selected cell format
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Displaying min value info
With Selection
MsgBox "Min value : " & iMin & vbCrLf & _
"Cell position " & vbCrLf & _
"Row : " & .Row & vbCrLf & _
"Column : " & .Column
End With
End Sub
As an additional info, the code above will display the cell info, row and column position of the cell containing the minimum/maximum value.
Imagine this condition; We are in the middle of doing something using Excel VBA macro, then we want the macro to automatically show the File Open dialog box to make us (user) able to choose another Excel file to be opened by Excel.
Got the picture? Below is vba procedure that do exactly like that, show the File Open dialog box, and open the Excel file selected by user.
Sub OpenExcelFile()
Dim vFile As Variant
'Showing Excel Open Dialog Form
vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & _
"*.xl*", 1, "Select Excel File", "Open", False)
'If Cancel then exit
If TypeName(vFile) = "Boolean" Then
Exit Sub
End If
'Open selected file
Workbooks.Open vFile
End Sub
Maybe for some reason we want to change our Microsoft Excel Status Bar, then this simple vba function will do the work for us.
The end result will look like this:
Ok, to do it, put this following code in ThisWorkbook code
Private Sub Workbook_Open()
'when workbook opened, change the status bar
Application.StatusBar = "Changing Excel Status Bar | excelvbamacro.com"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'remove status bar info before workbook closed
Application.StatusBar = False
End Sub
Now we can brag to our friends about our Excel status bar when we opened our Excel Workbook 
)
This handy VBA procedure is just to show you how we can calculate and display someone Age. To do this, of course we need to know their date of birth first, then simply using datediff and mod vba functions we can calculate how old is he/she.
Sub PersonAge()
Dim iYears As Integer, iMonths As Integer, iMonth As Integer
Dim dtDateofbirth As Date
dtDateofbirth = _
CDate(InputBox("Input your date of birth (yyyy-mm-dd)", "Date of birth"))
iYears = DateDiff("yyyy", CDate(dtDateofbirth), Date)
iMonths = (DateDiff("m", CDate(dtDateofbirth), Date)) Mod (iYears * 12)
MsgBox "Your age are " & iYears & " year(s) and " & iMonths & " month(s)"
End Sub
For this example, I use MsgBox and InputBox to get input and display the output data, but we can change it to worksheet cells reference if we want to integrate this calculation in our Excel Worksheet.
We can get an input from user using Input Box, but we also can use the Input Box to get the address of cell reference in Microsoft Excel.
Using simple Excel VBA procedure below we can ask user to select range of cells (as copy input) and where they want it paste.
Sub CopyPaste()
Dim InputCells As Excel.Range
Dim OutputCells As Excel.Range
On Error Resume Next
'Show input box to get range of cells that want to copy
Set InputCells = _
Application.InputBox(Prompt:="Block input cells/range", _
Title:="Copy Paste", Type:=8)
'Show input box to get where they want it paste
Set OutputCells = _
Application.InputBox(Prompt:="Select cell where you want paste it", _
Title:="Copy Paste", Type:=8)
'Copy range of input cells
InputCells.Copy
'Paste it into output cells reference
OutputCells.PasteSpecial (xlPasteAll)
End Sub
Run the excel macro, when the first input box show up, block range of cells that we want to copy, click OK, and when the second input box showed, choose destination cell and click OK, then the source cells will be copied into the destination cell.
