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

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top