VBA Snippets

Address_ColumnLetter

Returns the column letter from a cell address containing a column and a row.

source code

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

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_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_ToPicture

Public Sub Cells_ToPicture(SourceRange As Range, FilePathName As String) 
Const sProcName As String = "SaveRangePic" 
Dim IID_IDispatch As GUID 
Dim uPicInfo As uPicDesc 
Dim IPic As IPicture 
Dim hPtr As Long 
   On Error GoTo ErrorHandler 
   SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap 
   OpenClipboard 0 
   hPtr = GetClipboardData(CF_BITMAP) 
   CloseClipboard 
   With IID_IDispatch 
       .Data1 = &H7BF80980 
       .Data2 = &HBF32 
       .Data3 = &H101A 
       .Data4(0) = &H8B 
       .Data4(1) = &HBB 
       .Data4(2) = &H0 
       .Data4(3) = &HAA 
       .Data4(4) = &H0 
       .Data4(5) = &H30 
       .Data4(6) = &HC 
       .Data4(7) = &HAB 
   End With 
   With uPicInfo 
       .Size = Len(uPicInfo) 
       .Type = PICTYPE_BITMAP 
       .hPic = hPtr 
       .hPal = 0 
   End With 
   OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic 
   stdole.SavePicture IPic, FilePathName 
   Exit Sub 
ErrorHandler: 
   Call Error_Handle(msMODULENAME, sProcName, Err.Number, Err.Description) 
End Sub

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long 
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long 
Private Declare Function CloseClipboard Lib "user32" () As Long 
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _ 
   (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long 

Private Type GUID 
    Data1 As Long 
    Data2 As Integer 
    Data3 As Integer 
    Data4(0 To 7) As Byte 
End Type 
Private Type uPicDesc 
    Size As Long 
    Type As Long 
    hPic As Long 
    hPal As Long 
End Type

Private Const CF_BITMAP = 2 
Private Const PICTYPE_BITMAP = 1

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

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

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