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