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