VBA Snippets

Message_DoesNotExist

Public Sub Message_NamedRangeDoesNotExist( _
         ByVal snamedrange As String)

Dim sMessage As String
   sMessage = "This workbook named range does not exist: " & _
              vbCrLf & vbCrLf & _
              "'" & snamedrange & "'"

   Call MsgBox(sMessage, vbOKOnly + vbInformation, modConstants.g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Named Range")
   Call Tracer_Add("MESSAGE", sMessage)
End Sub

Wbk_NamedRangeConstantExists

Public Function Wbk_NamedRangeConstantExists( _
         ByVal snamedrange As String) As Boolean
    
Dim vValue As Variant

    On Error GoTo ErrorHandler

    vValue = ActiveWorkbook.Names.Item(snamedrange).Value
    NamedRangeConstant_Exists = True

    Exit Function
ErrorHandler:
    NamedRangeConstant_Exists = False
End Function

Wbk_NamedRangeDelete

Public Sub Wbk_NamedRangeDelete( _
         ByVal objWorkbook As Excel.Workbook, _
         ByVal sPrefix As String)
    
Const sPROCNAME As String = "Wbk_NamedRangeDelete"

Dim inamescounter As Integer

    On Error GoTo ErrorHandler

    For inamescounter = objWorkbook.Names.Count To 1 Step -1
        If Left(objWorkbook.Names.Item(inamescounter).Name, Len(sPrefix)) = sPrefix Then
           objWorkbook.Names.Item(inamescounter).Delete
        End If
    Next inamescounter

    Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Wbk_NamedRangeExists

Public Function Wbk_NamedRangeExists( _
         ByVal snamedrange As String) As Boolean
    
Dim objrange As Excel.Range
    On Error GoTo ErrorHandler
    Set objrange = Range(snamedrange)
    NamedRange_Exists = True

    Exit Function
ErrorHandler:
    NamedRange_Exists = False
End Function

Wbk_NamedRangeGet

Public Function Wbk_NamedRangeGet( _
         ByVal sWshName As String, _
         ByVal sNamedRange As String, _
Optional ByVal bRemoveEquals As Boolean = True) As String

Const sPROCNAME As String = "Wbk_NamedRangeGet"
Dim owsh As Excel.Worksheet
Dim inamescounter As Integer
      
   On Error GoTo ErrorHandler

   owsh = Application.Worksheets(sWshName)
   For inamescounter = 1 To owsh.Names.Count
      If owsh.Names.Item(inamescounter).Name = sNamedRange Then
         NamedRangeGet = owsh.Names.Item(inamescounter).Value
         Exit For
      End If
   Next
   If bRemoveEquals = True Then
      NamedRangeGet = NamedRangeGet.Substring(1, NamedRangeGet.Length - 1)
   End If

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
        "return the contents of the named range '" & sNamedRange & "'.")
End Function

Wbk_NamedRangeRedefine

Public Sub Wbk_NamedRangeRedefine( _
         ByVal sNamedRangeName As String, _
         ByVal sWshName As String, _
         ByVal sColFirst As String, _
         ByVal lRowFirst As Long, _
         ByVal sColLast As String, _
         ByVal lRowLargest As Long)

Const sPROCNAME As String = "Wbk_NamedRangeRedefine"

Dim llastrow As Long
Dim oStartCell As Range
Dim oFinishCell As Range
Dim oRange As Range

    On Error GoTo ErrorHandler
    llastrow = Sheets(sWshName).Range(Sheets(sWshName).Range(sColFirst & lRowLargest).End(XlDirection.xlUp).Address).Row

    Set oStartCell = Sheets(sWshName).Range(sColFirst & lRowFirst)
    Set oFinishCell = Sheets(sWshName).Range(sColLast & llastrow)
    Set oRange = Sheets(sWshName).Range(oStartCell.Address & ":" & oFinishCell.Address)

    Application.Names.Add Name:=sNamedRangeName, RefersTo:=Sheets(sWshName).Range(oRange.Address)

    Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Wbk_NamedRangesConstantsToArray

Public Function Wbk_NamedRangesConstantsToArray( _
         ByVal sSubStrStart As String, _
         ByVal sSubStrMiddle As String, _
         ByVal sSubStrEnd As String) As Variant

Const sPROCNAME As String = "Wbk_NamedRangesConstantsToArray"

Dim snamedrange As String
Dim vArrayName As Variant
Dim lnamescounter As Long
Dim lnamesfound As Long

    On Error GoTo ErrorHandler
   
    ReDim vArrayName(1 To 2, 1 To ActiveWorkbook.Names.Count)
    lnamesfound = 0
    If (Len(sSubStrStart) > 0) Then
        For lnamescounter = 1 To ActiveWorkbook.Names.Count
            snamedrange = ActiveWorkbook.Names(lnamescounter).Name
            If (Len(snamedrange) > Len(sSubStrStart)) Then
                If (UCase(VBA.Left(snamedrange, Len(sSubStrStart))) = UCase(sSubStrStart)) Then
                    lnamesfound = lnamesfound + 1
                    
                    vArrayName(1, lnamesfound) = Right(snamedrange, Len(snamedrange) - Len(sSubStrStart))
                    vArrayName(2, lnamesfound) = Mid(ActiveWorkbook.Names(lnamescounter).Value, 3, 2)
                End If
            End If
        Next lnamescounter
    End If
    ReDim Preserve vArrayName(1 To 2, 1 To lnamesfound)
    Wbk_NamedRangesConstantsToArray = vArrayName
    Exit Function
   
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function