VBA - Snippets
ACRONYM
Public Function ACRONYM( _
ByVal sText As String, _
Optional ByVal bJustCapitals As Boolean = False) _
As String
Dim sreturn As String
Dim inextspace As Integer
Dim sfirstcharacter As String
Dim sword As String
sText = VBA.Trim(sText)
Do While VBA.Len(sText) > 0
inextspace = VBA.InStr(1, sText, " ")
If (inextspace > 0) Then
sword = VBA.Trim(VBA.Left(sText, inextspace - 1))
sText = VBA.Right(sText, VBA.Len(sText) - inextspace)
Else
sword = sText
sText = ""
End If
sfirstcharacter = VBA.Left(sword, 1)
If (bJustCapitals = True) Then
If (VBA.Asc(sfirstcharacter) >= 65 And VBA.Asc(sfirstcharacter) <= 90) Then
sreturn = sreturn & VBA.UCase(sfirstcharacter)
End If
End If
If (bJustCapitals = False) Then
sreturn = sreturn & VBA.UCase(sfirstcharacter)
End If
Loop
ACRONYM = sreturn
End Function
AGE
Public Function AGE( _
ByVal dtBirthday As Date) _
As Integer
' Make sure passed-in value is a date.
If Not IsDate(dteBirthdate) Then
dteBirthdate = Date
End If
' Make sure date is not in the future.
If (dteBirthdate > Date) Then
dteBirthdate = Date
End If
If Int(dtBirthday) > 0 Then
Select Case Month(Date())
Case Is < Month(dtBirthday)
AGE = Year(Date()) - Year(dtBirthday) - 1
Case Is = Month(dtBirthday)
If Day(Date) >= Day(dtBirthday) Then
AGE = Year(Date()) - Year(dtBirthday)
Else
AGE = Year(Date()) - Year(dtBirthday) - 1
End If
Case Is > Month(dtBirthday)
AGE = Year(Date()) - Year(dtBirthday)
End Select
Else
AGE = CVErr(xlErrNA)
End If
End Function
AVERAGEVISIBLE
Public Function AVERAGEVISIBLE( _
ByVal rgeValues As Range) _
As Double
Dim rgeCell As Range
Dim ltotalcells As Long
Dim dbtotalvalue As Double
Dim dbaverage As Double
Application.Volatile
For Each rgeCell In rgeValues
If (rgeCell.EntireRow.Hidden = False) And _
(rgeCell.EntireColumn.Hidden = False) Then
If (Len(rgeCell.Value) > 0) Then
If (rgeCell.Value <> "True") And _
(rgeCell.Value <> "False") And _
(Application.WorksheetFunction.IsText(rgeCell.Value) <> True) Then
dbtotalvalue = dbtotalvalue + rgeCell.Value
ltotalcells = ltotalcells + 1
End If
End If
End If
Next rgeCell
dbaverage = (dbtotalvalue / ltotalcells)
AVERAGEVISIBLE = dbaverage
End Function
Public Function AVERAGEVISIBLE2( _
ByVal rgeValues As Range) _
As Double
Dim dbaverage As Double
dbaverage = Application.WorksheetFunction.Aggregate(1, 5, rgeValues)
AVERAGEVISIBLE2 = dbaverage
End Function
Builtin_FunctionMax
Public Function Function_MaxNo( _
ByVal lrowno_one As Long, _
ByVal lrowno_two As Long, _
ByVal lrowno_three As Long, _
Optional ByVal lrowno_four As Long = 0, _
Optional ByVal lrowno_five As Long = 0) _
As Long
Function_MaxNo = Application.WorksheetFunction.Max(lrowno_one, lrowno_two, lrowno_three, lrowno_four, lrowno_five)
End Function
CONTAINS
Public Function CONTAINS( _
ByVal sText1 As String, _
ByVal sText2 As String, _
Optional ByVal bIgnoreCase As Boolean = False) _
As Boolean
Call Application.Volatile(True)
CONTAINS = False
If Len(sText1) = 0 Or Len(sText2) = 0 Then Exit Function
If bIgnoreCase = False Then
If UCase(sText2) Like "*" & UCase(sText1) & "*" Then
CONTAINS = True
End If
Else
If sText2 Like "*" & sText1 & "*" Then
CONTAINS = True
End If
End If
End Function
COUNTBETWEEN
Public Function COUNTBETWEEN( _
ByVal rgeValues As Range, _
ByVal minValue As Single, _
ByVal maxValue As Single, _
Optional ByVal bInclusive As Boolean = True) _
As Variant
Dim objcell As Range
Dim itotalcells As Integer
itotalcells = 0
If (rgeValue.Cells.Count > 10000) Then
COUNTBETWEEN = "no column references"
Exit Function
End If
If (bInclusive = True) Then
For Each objcell In rgeValue
If (objcell.Value >= minValue) And (objcell.Value <= maxValue) Then
itotalcells = itotalcells + 1
End If
Next objcell
End If
If (bInclusive = False) Then
For Each objcell In rgeValue
If (objcell.Value > minValue) And (objcell.Value < maxValue) Then
itotalcells = itotalcells + 1
End If
Next objcell
End If
COUNTBETWEEN = itotalcells
End Function
COUNTFORMAT
Public Function COUNTFORMAT( _
ByVal rgeValues As Range, _
ByVal rgeExampleCell As Range, _
Optional ByVal bCheckBackGround As Boolean = True, _
Optional ByVal bCheckFontColor As Boolean = False, _
Optional ByVal bCheckFontBold As Boolean = False) _
As Integer
Dim objcell As Range
Dim itotalcells As Integer
Dim bbackground_check As Boolean
Dim bfontcolour_check As Boolean
Dim bfontbold_check As Boolean
itotalcells = 0
For Each objcell In rgeValues
bbackground_check = True
bfontcolour_check = True
bfontbold_check = True
If (bCheckBackGround = True) Then
If objcell.Interior.ColorIndex <> rgeExampleCell.Interior.ColorIndex Then
bbackground_check = False
End If
End If
If (bCheckFontColor = True) Then
If objcell.Font.ColorIndex <> rgeExampleCell.Font.ColorIndex Then
bfontcolour_check = False
End If
End If
If (bCheckFontBold = True) Then
If (objcell.Font.Bold = False) Then
bfontbold_check = False
End If
End If
If (bbackground_check = True) And (bfontcolour_check = True) And (bfontbold_check = True) Then
itotalcells = itotalcells + 1
End If
Next objcell
COUNTFORMAT = itotalcells
End Function
'rgeSearchCells - The range of cells you want to check
'rgeExampleCell - The cell with the colour you want to count
Public Function COUNTFORMAT_CELLCOLOR( _
ByVal rgeColouredCells As Range, _
ByVal rgeExampleCell As Range) As Long
Dim ltotal As Long
Dim rgecell As Range
Dim lcellcolour As Long
lcellcolour = rgeExampleCell.Interior.ColorIndex
For Each rgecell in rgeColouredCells
If rgecell.Interior.ColorIndex = lcellcolour Then
ltotal = ltotal + 1
End If
Next rgecell
COUNTFORMAT_CELLCOLOR = ltotal
End Function
'rgeSearchCells - The range of cells you want to check
Public Function COUNTFORMAT_FONTBOLD( _
ByVal rgeSearchCells As Range) As Long
Dim ltotal As Long
Dim rgecell As Range
For Each rgecell In rgeSearchCells
If (rgecell.Font.Bold = True) Then
ltotal = ltotal + 1
End If
Next rgecell
COUNTFORMAT_FONTBOLD = ltotal
End Function
'rgeSearchCells - The range of cells you want to check
'rgeExampleCell - The cell with the font colour you want to count
Public Function COUNTFORMAT_FONTCOLOR( _
ByVal rgeSearchCells As Range, _
ByVal rgeExampleCell As Range) As Long
Dim ltotal As Long
Dim lfontcolor As Long
Dim rgecell As Range
lfontcolor = rgeExampleCell.Font.Color
For Each rgecell In rgeSearchCells
If (rgecell.Font.Color = lfontcolor) Then
ltotal = ltotal + 1
End If
Next rgecell
COUNTFORMAT_FONTCOLOR = ltotal
End Function
COUNTSUBSTRING
Public Function COUNTSUBSTRING( _
ByVal sText As String, _
ByVal sSubString As String, _
Optional ByVal bCaseSensitive As Boolean = True) As Integer
Dim itotalcells As Integer
If (bCaseSensitive = True) Then
itotalcells = UBound(VBA.Split(UCase(sText), UCase(sSubString)))
End If
If (bCaseSensitive = False) Then
itotalcells = UBound(VBA.Split(sText, sSubString))
End If
COUNTSUBSTRING = itotalcells
End Function
COUNTVISIBLE
Public Function COUNTVISIBLE( _
ByVal rgeValues As Range) _
As Integer
Dim rgeCell As Range
Dim ltotalcells As Long
Application.Volatile
For Each rgeCell In rgeValues
If (rgeCell.EntireRow.Hidden = False) And _
(rgeCell.EntireColumn.Hidden = False) Then
If (Len(rgeCell.Value) > 0) Then
If (rgeCell.Value <> "True") And _
(rgeCell.Value <> "False") And _
(Application.WorksheetFunction.IsText(rgeCell.Value) <> True) Then
ltotalcells = ltotalcells + 1
End If
End If
End If
Next rgeCell
COUNTVISIBLE = ltotalcells
End Function
Public Function COUNTVISIBLE2( _
ByVal rgeValues As Range) _
As Integer
Dim ltotalcells As Integer
ltotalcells = Application.WorksheetFunction.Aggregate(2, 5, rgeValues)
COUNTVISIBLE2 = ltotalcells
End Function
DATESERIAL
Public Function DATESERIAL(ByVal sTheDate As String, _
ByVal sDateFormat As String) _
As Variant
Dim arcomponents As Variant
Dim iyear As Integer
Dim imonth As Integer
Dim iday As Integer
If (InStr(sTheDate, "/") > 0) Then
arcomponents = Split(sTheDate, "/")
If (Len(arcomponents(0)) = 1) Then arcomponents(0) = "0" & arcomponents(0)
If (Len(arcomponents(1)) = 1) Then arcomponents(1) = "0" & arcomponents(1)
sTheDate = arcomponents(0) & "/" & arcomponents(1) & "/" & arcomponents(2)
Select Case sDateFormat
Case "dd/mm/yyyy":
iyear = Mid(sTheDate, 7, 4)
imonth = Mid(sTheDate, 4, 2)
iday = Left(sTheDate, 2)
Case "mm/dd/yyyy":
iyear = Mid(sTheDate, 7, 4)
imonth = Left(sTheDate, 2)
iday = Mid(sTheDate, 4, 2)
Case Default:
DATESERIAL = "format not found"
Exit Function
End Select
End If
DATESERIAL = VBA.DateSerial(iyear, imonth, iday)
End Function
EXTRACTNUMBERS
Public Function EXTRACTNUMBERS( _
ByVal sText As String, _
Optional ByVal iNumberIndex As Integer = 1, _
Optional ByVal IncludeDecimals As Boolean = False, _
Optional ByVal IncludeNegatives As Boolean = False) _
As Variant
Dim iCount As Integer
Dim iCountNumbers As Integer
Dim iCountPosition As Integer
Dim sChar As String
Dim sChar_Decimal As String
Dim sChar_Negative As String
Dim sNumbers As String
sChar_Decimal = vbNullString
If (IncludeDecimals = True) Then sChar_Decimal = "."
sChar_Negative = vbNullString
If (IncludeNegatives = True) Then sChar_Negative = "-"
iCountPosition = 1
For iCount = 1 To Len(sText)
sChar = Left(sText, 1)
sText = Right(sText, Len(sText) - 1)
If ((IsNumeric(sChar)) Or _
(sChar = sChar_Negative) Or _
(sChar = sChar_Decimal)) Then
iCountNumbers = iCountNumbers + 1
If (sChar <> sChar_Negative) Then
sNumbers = sNumbers & sChar
Else
If (Len(sNumbers) = 0) Then
sNumbers = sNumbers & sChar
End If
End If
If ((IsNumeric(sNumbers) = True) And (sChar <> sChar_Negative)) Then
If (CDbl(sNumbers) < 0) Then
Exit For
End If
End If
Else
If ((Len(sNumbers) > 0) And _
((sNumbers <> sChar_Negative) And (sNumbers <> sChar_Decimal))) Then
If (iCountPosition = iNumberIndex) Then
Exit For
Else
sNumbers = ""
iCountPosition = iCountPosition + 1
End If
Else
sNumbers = ""
End If
End If
If ((iCountNumbers = 1) And (sNumbers <> vbNullString)) Then
sNumbers = Mid(sNumbers, 1, 1)
End If
Next iCount
If (Len(sNumbers) = 0) Then ExtractNumbers = "#N/A"
If (Len(sNumbers) > 0) Then ExtractNumbers = CDbl(sNumbers) End Function
Public Sub Testing_ExtractNumbers()
' Debug.Print ExtractNumbers("A889.5D-A1234-E", 1) '889
' Debug.Print ExtractNumbers("A889.5D-A1234-E", 1, True) '889.5
' Debug.Print ExtractNumbers("A889.5D-A1234-E", 1, True, True) '889.5
Debug.Print ExtractNumbers("A889.5D-A1234-E", 2) '5
Debug.Print ExtractNumbers("A889.5D-A1234-E", 2, True) '1234
Debug.Print ExtractNumbers("A889.5D-A1234-E", 2, True, True) '1234
Debug.Print ExtractNumbers("A889.5D-A1234-E", 2, False, True)
' Debug.Print ExtractNumbers("A889.5D-A1234-E", 3)
' Debug.Print ExtractNumbers("A889.5D-A1234-E", 3, True)
' Debug.Print ExtractNumbers("A889.5D-A1234-E", 3, True, True)
End Sub
MAXVISIBLE
Public Function MAXVISIBLE( _
ByVal rgeValues As Range) _
As Double
Dim rgeCell As Range
Dim dbmax As Double
Application.Volatile
For Each rgeCell In rgeValues
If (rgeCell.EntireRow.Hidden = False) And _
(rgeCell.EntireColumn.Hidden = False) Then
If (Len(rgeCell.Value) > 0) Then
If (rgeCell.Value <> "True") And _
(rgeCell.Value <> "False") And _
(Application.WorksheetFunction.IsText(rgeCell.Value) <> True) Then
If (dbmax = 0) Then
dbmax = rgeCell.Value
End If
If (rgeCell.Value > dbmax) Then
dbmax = rgeCell.Value
End If
End If
End If
End If
Next rgeCell
MAXVISIBLE = dbmax
End Function
Public Function MAXVISIBLE2( _
ByVal rgeValues As Range) _
As Double
Dim dbmax As Double
dbmax = Application.WorksheetFunction.Aggregate(4, 5, rgeValues)
MAXVISIBLE2 = dbmax
End Function
MINVISIBLE
Public Function MINVISIBLE( _
ByVal rgeValues As Range) _
As Double
Dim rgeCell As Range
Dim dbmin As Double
Application.Volatile
For Each rgeCell In rgeValues
If (rgeCell.EntireRow.Hidden = False) And _
(rgeCell.EntireColumn.Hidden = False) Then
If (Len(rgeCell.Value) > 0) Then
If (rgeCell.Value <> "True") And _
(rgeCell.Value <> "False") And _
(Application.WorksheetFunction.IsText(rgeCell.Value) <> True) Then
If (dbmin = 0) Then
dbmin = rgeCell.Value
End If
If (rgeCell.Value < dbmin) Then
dbmin = rgeCell.Value
End If
End If
End If
End If
Next rgeCell
MINVISIBLE = dbmin
End Function
Public Function MINVISIBLE2( _
ByVal rgeValues As Range) _
As Double
Dim dbmin As Double
dbmin = Application.WorksheetFunction.Aggregate(5, 5, rgeValues)
MINVISIBLE2 = dbmin
End Function
REVERSE
Public Function REVERSE( _
ByVal sCellContents As String) _
As String
If Application.WorksheetFunction.IsNonText(sCellContents) = True Then
REVERSE = VBA.CVErr(xlCVError.xlErrNA)
Else
REVERSE = VBA.StrReverse(sCellContents)
End If
End Function
Sample_RegionalBreakdownByDay
Public Sub Sample_RegionalBreakdownByDay(ByVal objCell As Excel.Range, _
Optional ByVal dbLowestValue As Double = 0, _
Optional ByVal dbHighestValue As Double = 100, _
Optional ByVal iNoOfDecimals As Integer = 0)
Dim lrowcount As Long
Call Cell_OffsetFormat(objCell, 0, 0, "Regional Breakdown by Day", True, xlHAlignLeft)
Call Cell_OffsetFormat(objCell, 1, 1, "Region 1", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 2, "Region 2", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 3, "Region 3", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 4, "Region 4", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 2, 0, "Monday", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 3, 0, "Tuesday", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 4, 0, "Wednesday", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 5, 0, "Thursday", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 6, 0, "Friday", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 7, 0, "Saturday", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 8, 0, "Sunday", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetInsertRandomNumbers(objCell.Offset(2, 1), 6, 3, dbLowestValue, dbHighestValue, iNoOfDecimals)
End Sub
Sample_RegionalBreakdownByYear
Public Sub Sample_RegionalBreakdownByYear(ByVal objCell As Excel.Range, _
Optional ByVal dbLowestValue As Double = 0, _
Optional ByVal dbHighestValue As Double = 100, _
Optional ByVal iNoOfDecimals As Integer = 0)
Call Cell_OffsetFormat(objCell, 0, 0, "Regional Breakdown of Downloads by Year", True, xlHAlignLeft)
Call Cell_OffsetFormat(objCell, 1, 1, "Region 1", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 2, "Region 2", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 3, "Region 3", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 4, "Region 4", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 2, 0, VBA.Year(VBA.Now) - 1, False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 3, 0, VBA.Year(VBA.Now) - 2, False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 4, 0, VBA.Year(VBA.Now) - 3, False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 5, 0, VBA.Year(VBA.Now) - 4, False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetInsertRandomNumbers(objCell.Offset(2, 1), 3, 3, dbLowestValue, dbHighestValue, iNoOfDecimals)
End Sub
Sample_RegionalBreakdownInJanuary
Public Sub Sample_RegionalBreakdownInJanuary(ByVal objCell As Excel.Range, _
Optional ByVal dbLowestValue As Double = 0, _
Optional ByVal dbHighestValue As Double = 100, _
Optional ByVal iNoOfDecimals As Integer = 0)
Dim lrowcount As Long
Call Cell_OffsetFormat(objCell, 0, 0, "Regional Breakdown of Downloads in January", True, xlHAlignLeft)
Call Cell_OffsetFormat(objCell, 1, 1, "Region 1", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 2, "Region 2", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 3, "Region 3", False, Excel.XlHAlign.xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 4, "Region 4", False, Excel.XlHAlign.xlHAlignRight)
For lrowcount = 1 To 31
Call Cell_OffsetFormat(objCell, 1 + lrowcount, 0, VBA.CDate(VBA.DateAdd("d", lrowcount - 1, "01/01/2012")), _
False, xlHAlignRight, "dd-mmm")
Next lrowcount
Call Cell_OffsetInsertRandomNumbers(objCell.Offset(2, 1), 30, 3, dbLowestValue, dbHighestValue, iNoOfDecimals)
End Sub
Sample_SalesByCountryHorizontal
Public Sub Sample_SalesByCountryHorizontal(ByVal objCell As Excel.Range, _
Optional ByVal dbLowestValue As Double = 0, _
Optional ByVal dbHighestValue As Double = 100, _
Optional ByVal iNoOfDecimals As Integer = 0)
Call Cell_OffsetFormat(objCell, 0, 0, "Sales by Country (horizontal)", True, xlHAlignLeft)
Call Cell_OffsetFormat(objCell, 1, 0, "France", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 1, "Germany", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 2, "Japan", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 3, "UK", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 4, "Australia", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 5, "Other", False, xlHAlignRight)
Call Cell_OffsetInsertRandomNumbers(objCell.Offset(2, 0), 0, 5, dbLowestValue, dbHighestValue, iNoOfDecimals)
End Sub
Sample_SalesByCountryVertical
Public Sub Sample_SalesByCountryVertical(ByVal objCell As Excel.Range, _
Optional ByVal dbLowestValue As Double = 0, _
Optional ByVal dbHighestValue As Double = 100, _
Optional ByVal iNoOfDecimals As Integer = 0)
Call Cell_OffsetFormat(objCell, 0, 0, "Sales by Country (vertical)", True, xlHAlignLeft)
Call Cell_OffsetFormat(objCell, 1, 0, "France", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 2, 0, "Germany", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 3, 0, "Japan", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 4, 0, "UK", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 5, 0, "Australia", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 6, 0, "Other", False, xlHAlignRight)
Call Cell_OffsetInsertRandomNumbers(objCell.Offset(1, 1), 5, 0, dbLowestValue, dbHighestValue, iNoOfDecimals)
End Sub
Sample_SalesByYearAndMonthNumbers
Public Sub Sample_SalesByYearAndMonth(ByVal objCell As Excel.Range, _
Optional ByVal dbLowestValue As Double = 0, _
Optional ByVal dbHighestValue As Double = 100, _
Optional ByVal iNoOfDecimals As Integer = 0)
Call Cell_OffsetFormat(objCell, 0, 0, "Sales by Year and Month", True, xlHAlignLeft)
Call Cell_OffsetFormat(objCell, 1, 1, VBA.Year(VBA.Now) - 1, False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 2, VBA.Year(VBA.Now) - 2, False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 3, VBA.Year(VBA.Now) - 3, False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 1, 4, VBA.Year(VBA.Now) - 4, False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 2, 0, "January", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 3, 0, "February", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 4, 0, "March", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 5, 0, "April", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 6, 0, "May", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 7, 0, "June", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 8, 0, "July", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 9, 0, "August", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 10, 0, "September", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 11, 0, "October", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 12, 0, "November", False, xlHAlignRight)
Call Cell_OffsetFormat(objCell, 13, 0, "December", False, xlHAlignRight)
Call Cell_OffsetInsertRandomNumbers(objCell.Offset(2, 1), 11, 3, dbLowestValue, dbHighestValue, iNoOfDecimals)
End Sub
Sample_SalesOnFirstDayOfEveryMonth
Public Sub Sample_NumberOfDownloadsOnFirstDayOfEveryMonth(ByVal objCell As Excel.Range, _
Optional ByVal dbLowestValue As Double = 0, _
Optional ByVal dbHighestValue As Double = 100, _
Optional ByVal iNoOfDecimals As Integer = 0)
Call Cell_OffsetFormat(objCell, 0, 0, "Number of Downloads on the First Day of Every Month", True, xlHAlignLeft)
Call Cell_OffsetFormat(objCell, 1, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 1, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 2, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 2, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 3, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 3, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 4, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 4, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 5, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 5, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 6, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 6, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 7, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 7, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 8, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 8, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 9, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 9, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 10, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 10, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 11, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 11, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetFormat(objCell, 12, 0, VBA.DateSerial(VBA.Year(VBA.Now) - 1, 12, 1), False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetInsertRandomNumbers(objCell.Offset(1, 1), 11, 0, dbLowestValue, dbHighestValue, iNoOfDecimals)
End Sub
Sample_SalesOnTwentyRandomDays
Public Sub Sample_NumberOfDownloadsOnTwentyRandomDays(ByVal objCell As Excel.Range, _
Optional ByVal dbLowestValue As Double = 0, _
Optional ByVal dbHighestValue As Double = 100, _
Optional ByVal iNoOfDecimals As Integer = 0)
Dim irandomnumber As Integer
Dim ldateserial As Long
Call Cell_OffsetFormat(objCell, 0, 0, "Number of Downloads on Twenty Random Days in a Year", True, xlHAlignLeft)
irandomnumber = 0
irandomnumber = Number_Random(irandomnumber, 18, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 1, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 36, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 2, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 54, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 3, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 72, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 4, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 90, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 5, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 108, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 6, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 126, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 7, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 144, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 8, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 162, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 9, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 180, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 10, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 198, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 11, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 216, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 12, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 234, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 13, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 252, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 14, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 270, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 15, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 288, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 16, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 306, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 17, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 324, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 18, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 342, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 19, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
irandomnumber = Number_Random(irandomnumber + 3, 364, 0)
ldateserial = VBA.DateAdd("d", irandomnumber, VBA.DateSerial(VBA.Year(VBA.Now - 1), 1, 1))
Call Cell_OffsetFormat(objCell, 20, 0, ldateserial, False, xlHAlignRight, "dd-mmm")
Call Cell_OffsetInsertRandomNumbers(objCell.Offset(1, 1), 19, 0, dbLowestValue, dbHighestValue, iNoOfDecimals)
End Sub
SCRAMBLE
Public Function SCRAMBLE( _
ByVal sCellContents As String) _
As String
Dim itextlength As Integer
Dim ichar As Integer
Dim irandomposition As Integer
Dim scharacter As String * 1
itextlength = Len(sCellContents)
For ichar = 1 To itextlength
scharacter = VBA.Mid(sCellContents, ichar, 1)
irandomposition = VBA.Int((itextlength - 1 + 1) * VBA.Rnd + 1)
Mid(sCellContents, ichar, 1) = VBA.Mid(sCellContents, irandomposition, 1)
Mid(sCellContents, irandomposition, 1) = scharacter
Next ichar
SCRAMBLE = sCellContents
End Function
SPELLNUMBER
Public Function SPELLNUMBER( _
ByVal dbMyNumber As Double, _
ByVal sMainUnitPlural As String, _
ByVal sMainUnitSingle As String, _
Optional ByVal sDecimalUnitPlural As String = "", _
Optional ByVal sDecimalUnitSingle As String = "") _
As Variant
Dim sMyNumber As String
Dim sConcat As String
Dim sDecimalText As String
Dim sTemp As String
Dim iDecimalPlace As Integer
Dim iCount As Integer
ReDim Place(9) As String
Application.Volatile (True)
Place(2) = "Thousand"
Place(3) = "Million"
Place(4) = "Billion"
Place(5) = "Trillion"
sMyNumber = Trim(CStr(dbMyNumber))
iDecimalPlace = InStr(dbMyNumber, ".")
If (iDecimalPlace > 0) Then
sDecimalText = GetTens(Left(Mid(Round(sMyNumber, 2), iDecimalPlace + 1) & "00", 2))
If Len(sDecimalText) > 0 Then
sMyNumber = Trim(Left(sMyNumber, iDecimalPlace - 1))
Else
sMyNumber = ""
End If
End If
iCount = 1
Do While sMyNumber <> ""
sTemp = GetHundreds(sMyNumber, Right(sMyNumber, 3), iDecimalPlace)
If (sTemp <> "") Then
If (iCount > 1) And (LCase(Left(Trim(sConcat), 3)) <> "and") Then
sConcat = ", " & sConcat
End If
sConcat = sTemp & Place(iCount) & sConcat
End If
If (Len(sMyNumber) > 3) Then
sMyNumber = Left(sMyNumber, Len(sMyNumber) - 3)
Else
sMyNumber = ""
End If
iCount = iCount + 1
Loop
Select Case Trim(sConcat)
Case "": sConcat = "No " & sMainUnitPlural
Case "One": sConcat = "One " & sMainUnitSingle
Case Else: sConcat = sConcat & sMainUnitPlural
End Select
If (iDecimalPlace > 0) Then
If (Len(sDecimalUnitPlural) > 0 And Len(sDecimalUnitSingle) > 0) Then
sConcat = sConcat & ", "
Select Case Trim(sDecimalText)
Case "": sDecimalText = "No " & sDecimalUnitPlural
Case "One": sDecimalText = "One " & sDecimalUnitSingle
Case Else: sDecimalText = sDecimalText & sDecimalUnitPlural
End Select
Else
sConcat = sConcat & " and "
sDecimalText = Mid(Trim(Str(dbMyNumber)), iDecimalPlace + 1) & "/100"
End If
End If
SPELLNUMBER = Trim(sConcat & sDecimalText)
End Function
Function GetHundreds(ByVal sMyNumber As String, _
ByVal sHundredNumber As String, _
ByVal iDecimal As Integer) As String
Dim sResult As String
If (sHundredNumber = "0") Then
Exit Function
End If
sHundredNumber = Right("000" & sHundredNumber, 3)
If Mid(sHundredNumber, 1, 1) <> "0" Then
sResult = GetDigit(Mid(sHundredNumber, 1, 1)) & "Hundred"
End If
If (sMyNumber > 1000) And (Mid(sHundredNumber, 3, 1) <> "0" Or _
Mid(sHundredNumber, 2, 1) <> "0") Or _
(Len(sResult) > 0) And (Mid(sHundredNumber, 3, 1) <> "0" Or _
Mid(sHundredNumber, 2, 1) <> "0") Then
sResult = sResult & " and "
End If
If Mid(sHundredNumber, 2, 1) <> "0" Then
sResult = sResult & GetTens(Mid(sHundredNumber, 2))
Else
If Mid(sHundredNumber, 3, 1) <> "0" Then
sResult = sResult & GetDigit(Mid(sHundredNumber, 3))
Else
sResult = sResult & " "
End If
End If
GetHundreds = sResult
End Function
Function GetTens(ByVal sTensText As String) As String
Dim sResult As String
sResult = ""
If Left(sTensText, 1) = 1 Then
Select Case sTensText
Case "10": sResult = "Ten "
Case "11": sResult = "Eleven "
Case "12": sResult = "Twelve "
Case "13": sResult = "Thirteen "
Case "14": sResult = "Fourteen "
Case "15": sResult = "Fifteen "
Case "16": sResult = "Sixteen "
Case "17": sResult = "Seventeen "
Case "18": sResult = "Eighteen "
Case "19": sResult = "Nineteen "
Case Else
End Select
Else
Select Case Left(sTensText, 1)
Case "2": sResult = "Twenty "
Case "3": sResult = "Thirty "
Case "4": sResult = "Forty "
Case "5": sResult = "Fifty "
Case "6": sResult = "Sixty "
Case "7": sResult = "Seventy "
Case "8": sResult = "Eighty "
Case "9": sResult = "Ninety "
Case Else
End Select
sResult = sResult & GetDigit(Right(sTensText, 1))
End If
GetTens = sResult
End Function
Function GetDigit(ByVal sDigit As String) As String
Select Case sDigit
Case "1": GetDigit = "One "
Case "2": GetDigit = "Two "
Case "3": GetDigit = "Three "
Case "4": GetDigit = "Four "
Case "5": GetDigit = "Five "
Case "6": GetDigit = "Six "
Case "7": GetDigit = "Seven "
Case "8": GetDigit = "Eight "
Case "9": GetDigit = "Nine "
Case Else: GetDigit = ""
End Select
End Function
SUMVISIBLE
Public Function SUMVISIBLE( _
ByVal rgeValues As Range) _
As Double
Dim rgeCell As Range
Dim dbtotal As Double
Application.Volatile
For Each rgeCell In rgeValues
If (rgeCell.EntireRow.Hidden = False) And _
(rgeCell.EntireColumn.Hidden = False) Then
If (Len(rgeCell.Value) > 0) Then
If (rgeCell.Value <> "True") And _
(rgeCell.Value <> "False") And _
(Application.WorksheetFunction.IsText(rgeCell.Value) <> True) Then
dbtotal = dbtotal + rgeCell.Value
End If
End If
End If
Next rgeCell
SUMVISIBLE = dbtotal
End Function
Public Function SUMVISIBLE2( _
ByVal rgeValues As Range) _
As Double
Dim dbtotal As Double
dbtotal = Application.WorksheetFunction.Aggregate(9, 5, rgeValues)
SUMVISIBLE2 = dbtotal
End Function
WORKBOOKFILENAME
Public Function WORKBOOKFILENAME(Optional ByVal rgeCellRange As Range = Nothing) As String
Application.Volatile
If rgeCellRange Is Nothing Then
WORKBOOKNAME = ActiveWorkbook.Name
Else
WORKBOOKNAME = rgeCellRange.Parent.Parent.Name
End If
End Function
WORKSHEETNAME
Public Function WORKSHEETNAME(Optional ByVal iSheetNo As Integer = -1) As String
If iSheetNo = -1 Then
WORKSHEETNAME = Application.ActiveSheet.Name
Else
WORKSHEETNAME = Application.Sheets(iSheetNo).Name
End If
End Function
© 2026 Better Solutions Limited. All Rights Reserved. © 2026 Better Solutions Limited Top