VBA Snippets

Message_DoesNotExist

Public Sub Message_NamedRangeDoesNotExist( _
         ByVal sNamedRangeName As String)

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

   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 sNamedRangeName As String) _
         As Boolean
    
Dim vvalue As Variant

    On Error GoTo ErrorHandler

    vvalue = ActiveWorkbook.Names.Item(sNamedRangeName).Value
    Wbk_NamedRangeConstantExists = True

    Exit Function
ErrorHandler:
    Wbk_NamedRangeConstantExists = False
End Function

Wbk_NamedRangeConstantsToArray

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

Const sPROCNAME As String = "Wbk_NamedRangesConstantToArray"

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

    On Error GoTo ErrorHandler
   
    ReDim varraytame(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
                    
                    varraytemp(1, lnamesfound) = Right(snamedrange, Len(snamedrange) - Len(sSubStrStart))
                    varraytemp(2, lnamesfound) = Mid(ActiveWorkbook.Names(lnamescounter).Value, 3, 2)
                End If
            End If
        Next lnamescounter
    End If
    ReDim Preserve varraytemp(1 To 2, 1 To lnamesfound)
    Wbk_NamedRangesConstantToArray = varraytemp

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

Wbk_NamedRangeDelete

Public Function Wbk_NamedRangeDelete( _
         ByVal oWorkbook As Excel.Workbook, _
         ByVal sNamedRangeName As String) _
         As Boolean
    
Const sPROCNAME As String = "Wbk_NamedRangeDelete"

   On Error GoTo ErrorHandler

   oWorkbook.Names.Item(sNamedRangeName).Delete
   Wbk_NamedRangeDelete = True

   Exit Function
ErrorHandler:
   Wbk_NamedRangeDelete = False
End Sub

Wbk_NamedRangeDeleteLoop

Public Function Wbk_NamedRangeDeleteLoop( _
         ByVal oWorkbook As Excel.Workbook, _
         ByVal sNamedRangeName As String) _
         As Boolean
    
Const sPROCNAME As String = "Wbk_NamedRangeDeleteLoop"

Dim inamescounter As Integer

    On Error GoTo ErrorHandler

    For inamescounter = objWorkbook.Names.Count To 1 Step -1
        If (oWorkbook.Names.Item(inamescounter).Name = sNamedRangeName) Then
           oWorkbook.Names.Item(inamescounter).Delete
           Wbk_NamedRangeDeleteLoop = True
           Exit Function
        End If
    Next inamescounter

    Wbk_NamedRangeDeleteLoop = False

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

Wbk_NamedRangeDeleteLoopPrefix

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

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, _
        "delete all the named ranges that have the prefix '" & sPrefix & "'.")
End Sub

Wbk_NamedRangeExists

Public Function Wbk_NamedRangeExists( _
         ByVal sNamedRangeName As String) As Boolean
    
Dim orange As Excel.Range

    On Error GoTo ErrorHandler

    Set orange = Application.Range(sNamedRangeName)
    Wbk_NamedRangeExists = True

    Exit Function
ErrorHandler:
    Wbk_NamedRangeExists = False
End Function

Wbk_NamedRangeGet

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

Const sPROCNAME As String = "Wbk_NamedRangeGet"

Dim oworksheet As Excel.Worksheet
Dim inamescounter As Integer
dim sreturn as String
      
   On Error GoTo ErrorHandler

   oworksheet = Application.Worksheets(sWshName)
   For inamescounter = 1 To oworksheet.Names.Count
      If (oworksheet.Names.Item(inamescounter).Name = sNamedRangeName) Then
         sreturn = oworksheet.Names.Item(inamescounter).Value
         Exit For
      End If
   Next
   If (bRemoveEquals = True) Then
      sreturn = sreturn.Substring(1, sreturn.Length - 1)
   End If
   Wbk_NamedRangeGet = sreturn 

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
        "return the contents of the named range '" & sNamedRangeName & "'.")
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