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_SortNamedRange_ByCustom

Public Sub Table_SortNamedRange_ByCustom( _
         ByVal sNamedRange As String, _
         ByVal sWshName As String, _
         ByVal lColFirst As Long, _
         ByVal lRowFirst As Long)

Const sPROCNAME As String = "Table_SortNamedRange_ByCustom"

Dim oRange As Excel.Range
Dim spasterange As String

   On Error GoTo ErrorHandler

   Set oRange = Worksheets(sWshName).Range(sNamedRange)
   spasterange = oRange.Address
   
'   Application.AddCustomList ListArray:=VBA.Array("AVP 3", "AVP 2", "AVP 1", "Analyst 3", "Analyst 2", "Analyst 1")
   
   Range(spasterange).Sort _
       Key1:=Cells(lRowFirst, lColFirst), _
       Header:=xlNo, _
       OrderCustom:=Application.CustomListCount + 1

'   Application.DeleteCustomList Application.CustomListCount

   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
   
   Range(spasterange).Sort _
       Key1:=Cells(lRowFirst, lColFirst), _
       Key2:=Cells(lRowLast, lColLast), _
       Header:=xlNo

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