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
© 2025 Better Solutions Limited. All Rights Reserved. © 2025 Better Solutions Limited Top