VBA Snippets
Address_ColumnLetter
Returns the column letter from a cell address containing a column and a row.source code
Cell_FormatNumber
anothe we df sdf.vba
Cell_OffsetFormat
Public Sub Cell_OffsetFormat(ByVal objCell As Excel.Range, _
ByVal iRowOffset As Integer, _
ByVal iColumnOffset As Integer, _
ByVal sText As String, _
ByVal bBold As Boolean, _
Optional ByVal enHAlignment As Excel.XlHAlign = XlHAlign.xlHAlignGeneral, _
Optional ByVal sNumberFormat As String = "")
On Error GoTo AnError
If Len(sNumberFormat) > 0 Then
objCell.Offset(iRowOffset, iColumnOffset).NumberFormat = sNumberFormat
End If
If IsDate(sText) = False Then
objCell.Offset(iRowOffset, iColumnOffset).Value = sText
Else
objCell.Offset(iRowOffset, iColumnOffset).Value = CLng(VBA.DateValue(sText))
End If
objCell.Offset(iRowOffset, iColumnOffset).Font.Bold = bBold
objCell.Offset(iRowOffset, iColumnOffset).HorizontalAlignment = enHAlignment
Exit Sub
AnError:
End Sub
Cell_OffsetInsertRandomNumbers
Public Sub Cell_OffsetInsertRandomNumbers(ByVal objCell As Excel.Range, _
ByVal iNoOfRows As Integer, _
ByVal iNoOfColumns As Integer, _
ByVal dbLowestValue As Double, _
ByVal dbHighestValue As Double, _
ByVal iNoOfDecimals As Integer, _
Optional ByVal bInsertFormula As Boolean = False)
Dim irowcount As Integer
Dim icolcount As Integer
On Error GoTo AnError
For irowcount = 0 To iNoOfRows
For icolcount = 0 To iNoOfColumns
objCell.Offset(irowcount, icolcount) = _
Number_Random(dbLowestValue, dbHighestValue, iNoOfDecimals)
Next icolcount
Next irowcount
Exit Sub
AnError:
End Sub
Cell_PositionReturn
vba
Cell_SelectCell
vba
Cell_TextToColumns
vba
Cell_TypeReturn
vba
Cell_ValueToDate
vba
Cell_ValueToString
vba
CellRef_GetColFirst
Public Function CellRef_GetColFirst(ByVal sCompleteReference As String, _
Optional ByVal bIncludeDollar As Boolean = False) As String
Dim sreference As String
Dim icharpos As Integer
Dim bfound As Boolean
On Error GoTo AnError
sreference = sCompleteReference
bfound = False
If bIncludeDollar = False Then 'remove any preceding dollar
If InStr(sreference, "$") = 1 Then
sreference = Right(sreference, Len(sreference) - 1)
icharpos = 0
End If
End If
Do While (bfound = False) And (icharpos <= Len(sCompleteReference))
icharpos = icharpos + 1
If IsNumeric(Mid(sreference, icharpos, 1)) = True Or _
((Mid(sreference, icharpos, 1) = "$") And _
(IsNumeric(Mid(sreference, icharpos + 1, 1)))) = True Then
bfound = True
End If
Loop
CellRef_GetColFirst = Left(sreference, icharpos - 1)
If icharpos = Len(sCompleteReference) Then
'maybe raise an error ??
'GoTo AnError
End If
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_GetColFirst", Err)
End Function
CellRef_GetColLast
Public Function CellRef_GetRowLast(ByVal sCompleteReference As String, _
Optional ByVal bIncludeDollar As Boolean = False) As String
Dim sreference As String
Dim icolon As Integer
On Error GoTo AnError
sreference = sCompleteReference
icolon = InStr(sreference, ":")
sreference = Right(sreference, Len(sreference) - icolon)
CellRef_GetRowLast = CellRef_GetRowFirst(sreference, bIncludeDollar)
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_GetRowLast", Err)
End Function
CellRef_GetRowFirst
Public Function CellRef_GetRowFirst(ByVal sCompleteReference As String, _
Optional ByVal bIncludeDollar As Boolean = False) As String
Dim sreference As String
Dim icolon As Integer
Dim bfound As Boolean
Dim icharpos As Integer
On Error GoTo AnError
sreference = sCompleteReference
bfound = False
If bIncludeDollar = False Then 'remove any preceding dollar
If InStr(sreference, "$") = 1 Then
sreference = Right(sreference, Len(sreference) - 1)
icharpos = 0
End If
End If
Do While (bfound = False) And (icharpos <= Len(sreference))
icharpos = icharpos + 1
If IsNumeric(Mid(sreference, icharpos, 1)) = True Or _
((Mid(sreference, icharpos, 1) = "$") And _
(IsNumeric(Mid(sreference, icharpos + 1, 1)))) = True Then
bfound = True
End If
Loop 'remove first column
sreference = Right(sreference, Len(sreference) - icharpos + 1)
If bIncludeDollar = False Then 'remove any preceding dollar
If InStr(sreference, "$") = 1 Then _
sreference = Right(sreference, Len(sreference) - 1)
End If
icolon = InStr(sreference, ":")
If icolon = 0 Then 'there is no range of cells
CellRef_GetRowFirst = sreference
Else
CellRef_GetRowFirst = Left(sreference, icolon - 1)
End If
If (icharpos = Len(sCompleteReference)) Then
'maybe raise an error
'GoTo AnError
End If
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_GetRowFirst", Err)
End Function
CellRef_GetRowLast
Public Function CellRef_GetRowLast(ByVal sCompleteReference As String, _
Optional ByVal bIncludeDollar As Boolean = False) As String
Dim sreference As String
Dim icolon As Integer
On Error GoTo AnError
sreference = sCompleteReference
icolon = InStr(sreference, ":")
sreference = Right(sreference, Len(sreference) - icolon)
CellRef_GetRowLast = CellRef_GetRowFirst(sreference, bIncludeDollar)
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_GetRowLast", Err)
End Function
CellRef_HasFolderPath
Public Function CellRef_HasFolderPath(ByVal sCompleteReference As String) As Boolean
Dim icolon As Integer
Dim isquarebracketopen As Integer
On Error GoTo AnError
icolon = InStr(sCompleteReference, ":")
isquarebracketopen = InStr(sCompleteReference, "[")
If (icolon > 0) And (icolon < isquarebracketopen) Then
CellRef_HasFolderPath = True
Else
CellRef_HasFolderPath = False
End If
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_HasFolderPath", Err)
End Function
CellRef_HasRange
vba
CellRef_HasWbkName
Public Function CellRef_HasWbkName(ByVal sCompleteReference As String) As Boolean
Dim isinglespeechmark As Integer
Dim isquarebracketopen As Integer
On Error GoTo AnError
isinglespeechmark = InStr(sCompleteReference, "'")
isquarebracketopen = InStr(sCompleteReference, "[")
If isinglespeechmark = 1 And isquarebracketopen = 2 Then
CellRef_HasWbkName = True
Else
CellRef_HasWbkName = False
End If
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_HasWbkName", Err)
End Function
CellRef_HasWshName
Public Function CellRef_HasWshName(ByVal sCompleteReference As String) As Boolean
Dim isinglespeechmark As Integer
Dim iexclamationmark As Integer
On Error GoTo AnError
isinglespeechmark = InStr(sCompleteReference, "'")
iexclamationmark = InStr(sCompleteReference, "!")
If (isinglespeechmark <> 0) Or _
(iexclamationmark <> 0) Then
CellRef_HasWshName = True
Else
CellRef_HasWshName = False
End If
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_HasWshName", Err)
End Function
CellRef_ReturnComponent
Public Function CellRef_ReturnComponent(ByVal sCompleteReference As String, _
ByVal sWhichComponent As String) As String
Dim bhas As Boolean
Dim rgecellrange As Excel.Range
Dim sreturn As String
On Error GoTo AnError
sreturn = "Missing"
Select Case sWhichComponent
Case "Folder Path"
bhas = CellRef_HasFolderPath(sCompleteReference)
If (bhas = True) Then
sreturn = CellRef_ReturnFolderPath(sCompleteReference)
End If
Case "Workbook"
bhas = CellRef_HasWbkName(sCompleteReference)
If (bhas = True) Then
sreturn = CellRef_ReturnWbkName(sCompleteReference)
End If
Case "Worksheet"
bhas = CellRef_HasWshName(sCompleteReference)
If (bhas = True) Then
sreturn = CellRef_ReturnWshName(sCompleteReference)
End If
Case "Range"
Set rgecellrange = CellRef_ReturnRange(sCompleteReference)
sreturn = rgecellrange.Address
End Select
CellRef_ReturnComponent = sreturn
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_ReturnComponent", Err)
End Function
CellRef_ReturnFolderPath
Public Function CellRef_ReturnFolderPath(ByVal sCompleteReference As String) As String
On Error GoTo AnError
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_ReturnFolderPath", Err)
End Function
CellRef_ReturnRange
Public Function CellRef_ReturnRange(ByVal sCompleteReference As String) As String
Dim iexclamationmark As Integer
Dim sreturn As String
On Error GoTo AnError
iexclamationmark = InStr(sCompleteReference, "!")
sreturn = Mid(sCompleteReference, iexclamationmark + 1)
CellRef_ReturnRange = sreturn
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_ReturnRange", Err)
End Function
CellRef_ReturnWbkName
Public Function CellRef_ReturnWbkName(ByVal sCompleteReference As String) As String
Dim isquarebracketopen As Integer
Dim isquarebracketclose As Integer
Dim sreturn As String
On Error GoTo AnError
isquarebracketopen = InStr(sCompleteReference, "[")
isquarebracketclose = InStr(sCompleteReference, "]")
sreturn = Mid(sCompleteReference, isquarebracketopen + 1, isquarebracketclose - isquarebracketopen - 1)
CellRef_ReturnWbkName = sreturn
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_ReturnWbkName", Err)
End Function
CellRef_ReturnWshName
Public Function CellRef_ReturnWshName(ByVal sCompleteReference As String) As String
Dim isquarebracketclose As Integer
Dim iexclamationmark As Integer
Dim isinglespeechmark As Integer
Dim sreturn As String
On Error GoTo AnError
iexclamationmark = InStr(sCompleteReference, "!")
sreturn = Left(sCompleteReference, iexclamationmark - 1)
isquarebracketclose = InStr(sCompleteReference, "]")
If (isquarebracketclose <> 0) Then
sreturn = Mid(sreturn, isquarebracketclose + 1)
End If
sreturn = Replace(sreturn, "'", "")
CellRef_ReturnWshName = sreturn
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_ReturnWshName", Err)
End Function
Cells_Clear
vba
Cells_Copy
vba
Cells_CopyPaste
vba
Cells_Cut
vba
Cells_Delete
vba
Cells_Format
vba
Cells_FormatBorderAdd
vba
Cells_FormatBorderAddTopBottom
vba
Cells_FormatBordersClear
vba
Cells_FormatInterior
vba
Cells_Insert
vba
Cells_RecordMove
vba
Cells_RemoveDuplicatesInColumn
vba
Cells_ToArray
vba
Cells_ToArrayLetters
vba
Cells_ToDataTable
vba
Cells_ToListBox
vba
Cells_ToListView
vba
Message_NoDataRangeHas2BlankCells
Public Sub Message_NoDataRangeHas2BlankCells()
Dim sMessage As String
sMessage = "This is not a valid selection." & _
vbCrLf & vbCrLf & _
"The first 2 cells in this range are blank."
Call MsgBox(sMessage, vbOKOnly + vbInformation, "Two Blank Cells")
Call Tracer_Add("MESSAGE", sMessage)
End Sub
Message_NoDataRangeIsSelected
Public Sub Message_NoDataRangeIsSelected()
Dim sMessage As String
sMessage = "You must select your cells first." & _
vbCrLf & vbCrLf & _
"The active window might have changed."
Call MsgBox(sMessage, vbOKOnly + vbInformation, "No Range Selected")
Call Tracer_Add("MESSAGE", sMessage)
End Sub
Message_RangeNoNumericalData
vba
Range_ColumnFirst
vba
Range_ColumnLast
vba
Range_ConcatenateText
vba
Range_ContainsRange
Public Function Range_ContainsRange(rng1, rng2) As Boolean
' Returns True if rng1 is a subset of rng2
InRange = False
If rng1.Parent.Parent.Name = rng2.Parent.Parent.Name Then
If rng1.Parent.Name = rng2.Parent.Name Then
If Union(rng1, rng2).Address = rng2.Address Then
InRange = True
End If
End If
End If
End Function
Range_HasNumericalData
vba
Range_OffSetValueToString
vba
Range_PasteSpecial
vba
Range_PasteSpecialText
vba
Range_RemoveSpaces
vba
Range_RowFirst
vba
Range_RowLast
vba
Range_ToListComboBox
vba
Ranges_SameColumns
Public Function Ranges_SameColumns(ByVal objRange1 As Range, _
ByVal objRange2 As Range) _
As Boolean
Dim bsamecolumns As Boolean
On Error GoTo AnError
bsamecolumns = False
If (objRange1.Column = objRange2.Column) Then
If (objRange1.Columns.Count = objRange2.Columns.Count) Then
bsamecolumns = True
End If
End If
Ranges_SameColumns = bsamecolumns
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "Ranges_SameColumns", Err)
End Function
Ranges_SameRows
Public Function Ranges_SameRows(ByVal objRange1 As Range, _
ByVal objRange2 As Range) _
As Boolean
Dim bsamerows As Boolean
On Error GoTo AnError
bsamerows = False
If (objRange1.Row = objRange2.Row) Then
If (objRange1.Rows.Count = objRange2.Rows.Count) Then
bsamerows = True
End If
End If
Ranges_SameRows = bsamerows
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "Ranges_SameRows", Err)
End Function
© 2023 Better Solutions Limited. All Rights Reserved. © 2023 Better Solutions Limited Top