VBA Snippets
Table_AddHeadings
Public Sub Table_AddHeadings( _
ByVal vHeadings As Variant, _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColLast As Long, _
ByVal lRowLast As Long)
Const sPROCNAME As String = "Table_AddHeadings"
On Error GoTo ErrorHandler
Call Array_PasteNoTranspose(vHeadings, sWshName, lColFirst, lRowFirst, lColLast, lRowLast)
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Table_ClearPrevious
Public Sub Table_ClearPrevious( _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColLast As Long, _
ByVal lRowLast As Long)
Const sPROCNAME As String = "Table_ClearPrevious"
Dim oStartCell As Range
Dim oFinishCell As Range
Dim oRange As Range
On Error GoTo ErrorHandler
Set oStartCell = Worksheets(sWshName).Cells(lRowFirst, lColFirst)
Set oFinishCell = Worksheets(sWshName).Cells(lRowLast, lColLast)
Set oRange = Worksheets(sWshName).Range(oStartCell.Address & ":" & oFinishCell.Address)
With oRange
.ClearContents
.Font.Bold = False
.Interior.ColorIndex = XlColorIndex.xlColorIndexNone
End With
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Table_ClearPreviousColours
Public Sub Table_ClearPreviousColours( _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColLast As Long, _
ByVal lRowLast As Long)
Const sPROCNAME As String = "Table_ClearPreviousColours"
Dim oStartCell As Range
Dim oFinishCell As Range
Dim oRange As Range
On Error GoTo ErrorHandler
Set oStartCell = Worksheets(sWshName).Cells(lRowFirst, lColFirst)
Set oFinishCell = Worksheets(sWshName).Cells(lRowLast, lColLast)
Set oRange = Worksheets(sWshName).Range(oStartCell.Address & ":" & oFinishCell.Address)
With oRange
.Interior.ColorIndex = XlColorIndex.xlColorIndexNone
End With
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Table_ColumnPopulate_OrderAndAutoFill
Public Sub Table_ColumnPopulate_OrderAndAutoFill( _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColLast As Long, _
ByVal lRowLast As Long)
Const sPROCNAME As String = "Table_ColumnPopulate_OrderAndAutoFill"
Dim oStartCell As Range
Dim oFinishCell As Range
Dim oRange As Range
Dim spasterange As String
On Error GoTo ErrorHandler
Set oStartCell = Worksheets(sWshName).Cells(lRowFirst, lColFirst)
Set oFinishCell = Worksheets(sWshName).Cells(lRowLast, lColLast)
Set oRange = Worksheets(sWshName).Range(oStartCell.Address & ":" & oFinishCell.Address)
spasterange = oRange.Address
'fill the additional order column
Worksheets(sWshName).Cells(lRowFirst, lColFirst).Value = 1
Worksheets(sWshName).Cells(lRowFirst, lColFirst).AutoFill _
Worksheets(sWshName).Range(spasterange), xlFillSeries
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Table_DefineNamedRange
Public Sub Table_DefineNamedRange( _
ByVal sNamedRangeName As String, _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColLast As Long, _
ByVal lRowLast As Long)
Const sPROCNAME As String = "Table_DefineNamedRange"
Dim oStartCell As Range
Dim oFinishCell As Range
Dim oRange As Range
Dim spasterange As String
On Error GoTo ErrorHandler
Set oStartCell = Worksheets(sWshName).Cells(lRowFirst, lColFirst)
Set oFinishCell = Worksheets(sWshName).Cells(lRowLast, lColLast)
Set oRange = Worksheets(sWshName).Range(oStartCell.Address & ":" & oFinishCell.Address)
spasterange = oRange.Address
Application.Names.Add Name:=sNamedRangeName, RefersTo:=Sheets(sWshName).Range(spasterange)
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Table_PopulateString
Populates a range of cells with the same text string.Public Sub Table_PopulateString( _
ByVal sTextString As String, _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColLast As Long, _
ByVal lRowLast As Long)
Const sPROCNAME As String = "Table_PopulateString"
Dim ostartcell As Range
Dim ofinishcell As Range
Dim orange As Range
Dim spasterange As String
On Error GoTo ErrorHandler
Set ostartcell = Worksheets(sWshName).Cells(lRowFirst, lColFirst)
Set ofinishcell = Worksheets(sWshName).Cells(lRowLast, lColLast)
Set orange = Worksheets(sWshName).Range(ostartcell.Address & ":" & ofinishcell.Address)
spasterange = orange.Address
Worksheets(sWshName).Range(spasterange).Value = sTextString
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Table_ShadeAlternateBlocks
Public Sub Table_ShadeAlternateBlocks( _
ByVal sWshName As String, _
ByVal lColBlock As Long, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColLast As Long, _
ByVal lRowLast As Long)
Const sPROCNAME As String = "Table_ShadeAlternateBlocks"
Dim lrowno As Long
Dim lrowblockstart As Long
Dim lrowblockfinish As Long
Dim bshade As Boolean
On Error GoTo ErrorHandler
bshade = True
For lrowno = lRowFirst To lRowLast
If (lrowno = lRowFirst) Then
lrowblockstart = lRowFirst
Else
If (Worksheets(sWshName).Cells(lrowno, lColBlock).Value <> _
Worksheets(sWshName).Cells(lrowno - 1, lColBlock).Value) Then
lrowblockfinish = lrowno - 1
If (bshade = True) Then
Call Cells_Shade(sWshName, lColFirst, lrowblockstart, lColLast, lrowblockfinish, 15921906)
End If
lrowblockstart = lrowno
bshade = Not bshade
End If
End If
If (lrowno = lRowLast) And (bshade = True) Then
Call Cells_Shade(sWshName, lColFirst, lrowblockstart, lColLast, lRowLast, 15921906)
End If
Next lrowno
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Table_SortNamedRange_ByCustom
Public Sub Table_SortNamedRange_ByColumn( _
ByVal sNamedRangeName As String, _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
Optional ByVal bDescending As Boolean = True, _
Optional ByVal enHeader As XlYesNoGuess = XlYesNoGuess.xlYes)
Const sPROCNAME As String = "Table_SortNamedRange_ByColumn"
Dim orange As Excel.Range
Dim spasterange As String
On Error GoTo ErrorHandler
Set orange = Worksheets(sWshName).Range(sNamedRangeName)
spasterange = orange.Address
If (bDescending = True) Then
Worksheets(sWshName).Range(spasterange).Sort _
Key1:=Worksheets(sWshName).Cells(lRowFirst, lColFirst), _
Order1:=xlDescending, _
Header:=enHeader
End If
If (bDescending = False) Then
Worksheets(sWshName).Range(spasterange).Sort _
Key1:=Worksheets(sWshName).Cells(lRowFirst, lColFirst), _
Order1:=xlAscending, _
Header:=enHeader
End If
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Table_SortNamedRange_ByThreeColumns
Public Sub Table_SortNamedRange_ByThreeColumns( _
ByVal sNamedRange As String, _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColSecond As Long, _
ByVal lColThird As Long, _
Optional ByVal enHeader As XlYesNoGuess = XlYesNoGuess.xlNo)
Const sPROCNAME As String = "Table_SortNamedRange_ByThreeColumns"
Dim orange As Excel.Range
Dim spasterange As String
On Error GoTo ErrorHandler
Set orange = Worksheets(sWshName).Range(sNamedRangeName)
spasterange = orange.Address
Worksheets(sWshName).Range(spasterange).Sort _
Key1:=Worksheets(sWshName).Cells(lRowFirst, lColFirst), _
Order1:=xlAscending, _
Key2:=Worksheets(sWshName).Cells(lRowFirst, lColSecond), _
Order2:=xlAscending, _
Key3:=Worksheets(sWshName).Cells(lRowFirst, lColThird), _
Order3:=xlAscending, _
Header:=enHeader
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Table_SortNamedRange_ByTwoColumns
Public Sub Table_SortNamedRange_ByTwoColumns( _
ByVal sNamedRange As String, _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColLast As Long, _
ByVal lRowLast As Long)
Const sPROCNAME As String = "Table_SortNamedRange_ByTwoColumns"
Dim oRange As Excel.Range
Dim spasterange As String
On Error GoTo ErrorHandler
Set oRange = Worksheets(sWshName).Range(sNamedRange)
spasterange = oRange.Address
Worksheets(sWshName).Range(spasterange).Sort _
Key1:=Worksheets(sWshName).Cells(lRowFirst, lColFirst), _
Key2:=Worksheets(sWshName).Cells(lRowLast, lColLast), _
Header:=xlNo
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