VBA Snippets


Table_AddColumn_Sum

Public Sub Table_AddColumn_Sum( _
         ByVal lColumn_Missing As Long, _
         ByVal lColumnFirst As Long, _
         ByVal lColumnLast As Long, _
         ByVal lRowFirst As Long, _
         ByVal lRowLast As Long, _
Optional ByVal lMinimumCol As Long = -1)
 
Const sPROCNAME As String = "Table_AddColumn_Sum"
 
Dim lrowno As Long
Dim lcolumnstart_offset As Long
Dim snoofweeks As String
 
   On Error GoTo ErrorHandler
 
   If (lMinimumCol > -1) Then
      If (lColumnFirst < lMinimumCol) Then lColumnFirst = lMinimumCol
      If (lColumnLast < lMinimumCol) Then lColumnLast = lMinimumCol
   End If
  
   lcolumnstart_offset = (lColumn_Missing - lColumnFirst)
 
   Sheets(g_sWSHNAME_SOURCES).Cells(lRowFirst - 1, lColumn_Missing) = "SUM"
 
   For lrowno = lRowFirst To lRowLast
      Sheets(g_sWSHNAME_SOURCES).Cells(lrowno, lColumn_Missing).Formula = "=SUM(RC[-" & lcolumnstart_offset & "]:RC[-1])"
      Sheets(g_sWSHNAME_SOURCES).Cells(lrowno, lColumn_Missing).NumberFormat = "0.00"
   Next lrowno
 
   Exit Sub
ErrorHandler:
'   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

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_DictionaryAverageByTwoColumns

Public Function Table_DictionaryAverageByTwoColumns( _
         ByVal vFilteredArray As Variant, _
         ByVal lColumnNo1_Rows As Long, _
         ByVal lColumnNo2_Columns As Long, _
         ByVal lColumnSumValue As Long, _
         ByRef dicUniqueColumn1_Rows As Scripting.Dictionary, _
         ByRef dicUniqueColumn2_Columns As Scripting.Dictionary) _
         As Scripting.Dictionary
 
Const sPROCNAME As String = "Table_DictionaryAverageByTwoColumns"
  
Dim dicResultsTable As Scripting.Dictionary
Dim lcount As Long
Dim sConCat As String
Dim sactualvalue As String
 
   On Error GoTo ErrorHandler
                                                   
   Set dicResultsTable = Table_DictionarySumByTwoColumns(vFilteredArray, _
                                                        lColumnNo1_Rows, _
                                                        lColumnNo2_Columns, _
                                                        lColumnSumValue, _
                                                        dicUniqueColumn1_Rows, _
                                                        dicUniqueColumn2_Columns, _
                                                        True)
                                                                                                       
Dim lAVERAGECOUNT As Long
Dim sngSUM As Single
                                                                                                       
   For lcount = 0 To dicResultsTable.Count - 1
      sConCat = dicResultsTable.Keys(lcount)
      sactualvalue = dicResultsTable.Items(lcount)
                    
      If (sactualvalue <> "") Then
         lAVERAGECOUNT = VBA.Split(dicResultsTable.Items(lcount), "#")(1)
         sngSUM = VBA.Split(dicResultsTable.Items(lcount), "#")(0)
     
         dicResultsTable.Item(sConCat) = sngSUM / lAVERAGECOUNT
      End If
   Next lcount
  
   Set Table_DictionaryAverageByTwoColumns = dicResultsTable
 
   Exit Function
ErrorHandler:
   MsgBox (Err.Number & " - " & Err.Description)
'   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Table_DictionaryCountByTwoColumns

Public Function Table_DictionaryCountByTwoColumns( _
         ByVal vFilteredArray As Variant, _
         ByVal lColumnNo1_Rows As Long, _
         ByVal lColumnNo2_Columns As Long, _
         ByVal lColumnCountValue As Long, _
         ByRef dicUniqueColumn1_Rows As Scripting.Dictionary, _
         ByRef dicUniqueColumn2_Columns As Scripting.Dictionary) _
         As Scripting.Dictionary
 
Dim dicFilterDictionary As Scripting.Dictionary
Dim dicUniqueCountDictionary As Scripting.Dictionary
Dim scolumn1value_rows As String
Dim scolumn2value_columns As String
Dim sactualvalue As String
Dim sConCat As String
Dim larrayno As Long
Dim lTOTALCOUNT As Long
 
   On Error GoTo ErrorHandler
 
   Set dicFilterDictionary = New Scripting.Dictionary
   Set dicUniqueCountDictionary = New Scripting.Dictionary
   Set dicUniqueColumn1_Rows = New Scripting.Dictionary
   Set dicUniqueColumn2_Columns = New Scripting.Dictionary
 
   For larrayno = 1 To UBound(vFilteredArray, 1)
      scolumn1value_rows = vFilteredArray(larrayno, lColumnNo1_Rows)
      scolumn2value_columns = vFilteredArray(larrayno, lColumnNo2_Columns)
 
      If ((scolumn1value_rows <> "") And (scolumn2value_columns <> "")) Then
 
         sactualvalue = vFilteredArray(larrayno, lColumnCountValue)
         If (sactualvalue <> "") Then
 
            sConCat = scolumn1value_rows & "#" & scolumn2value_columns
 
            If (dicUniqueColumn1_Rows.Exists(scolumn1value_rows) = False) Then
               dicUniqueColumn1_Rows.Add scolumn1value_rows, 0
            End If
 
            If (dicUniqueColumn2_Columns.Exists(scolumn2value_columns) = False) Then
               dicUniqueColumn2_Columns.Add scolumn2value_columns, 0
            End If
 
 
 
            If (dicUniqueCountDictionary.Exists(sConCat & "#" & sactualvalue) = False) Then
           
               If (dicFilterDictionary.Exists(sConCat) = False) Then
                  dicFilterDictionary.Add sConCat, 1
               Else
                  dicFilterDictionary.Item(sConCat) = dicFilterDictionary.Item(sConCat) + 1
               End If
           
               dicUniqueCountDictionary.Add sConCat & "#" & sactualvalue, 1
 
            End If
         End If
 
      End If
   Next larrayno
 
   Set Table_DictionaryCountByTwoColumns = dicFilterDictionary
 
   Exit Function
ErrorHandler:
   MsgBox (Err.Number & " - " & Err.Description)
'   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Table_DictionaryPercentageByTwoColumns

Public Function Table_DictionaryPercentageByTwoColumns( _
         ByVal vFilteredArray As Variant, _
         ByVal lColumnNo1_Rows As Long, _
         ByVal lColumnNo2_Columns As Long, _
         ByVal lColumnSumValue As Long, _
         ByRef dicUniqueColumn1_Rows As Scripting.Dictionary, _
         ByRef dicUniqueColumn2_Columns As Scripting.Dictionary) _
         As Scripting.Dictionary
 
Dim dicResultsTable As Scripting.Dictionary
Dim lcount As Long
Dim sConCat As String
Dim scolumn1value_rows As String
Dim scolumn2value_columns As String
Dim sactualvalue As String
Dim sngRowsTotal As Single
Dim sngColumnsTotal As Single
 
Const sPROCNAME As String = "Table_DictionarySumByTwoColumns"
 
   On Error GoTo ErrorHandler
  
   Set dicResultsTable = Table_DictionarySumByTwoColumns(vFilteredArray, _
                                                        lColumnNo1_Rows, _
                                                        lColumnNo2_Columns, _
                                                        lColumnSumValue, _
                                                        dicUniqueColumn1_Rows, _
                                                        dicUniqueColumn2_Columns)
 
   For lcount = 0 To dicResultsTable.Count - 1
      sConCat = dicResultsTable.Keys(lcount)
      scolumn1value_rows = Split(sConCat, "#")(0)
      scolumn2value_columns = Split(sConCat, "#")(1)
      sactualvalue = dicResultsTable.Items(lcount)
      sngRowsTotal = dicUniqueColumn1_Rows.Item(scolumn1value_rows)
      sngColumnsTotal = dicUniqueColumn2_Columns.Item(scolumn2value_columns)
     
      If (sactualvalue <> "") Then
         dicResultsTable.Item(sConCat) = sactualvalue / sngColumnsTotal
      End If
   Next lcount
  
   Set Table_DictionaryPercentageByTwoColumns = dicResultsTable
 
   Exit Function
ErrorHandler:
   MsgBox (Err.Number & " - " & Err.Description)
'   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Table_DictionarySumByTwoColumns

Public Function Table_DictionarySumByTwoColumns( _
         ByVal vFilteredArray As Variant, _
         ByVal lColumnNo1_Rows As Long, _
         ByVal lColumnNo2_Columns As Long, _
         ByVal lColumnSumValue As Long, _
         ByRef dicUniqueColumn1_Rows As Scripting.Dictionary, _
         ByRef dicUniqueColumn2_Columns As Scripting.Dictionary, _
Optional ByVal bAddAverageCount As Boolean = False) _
         As Scripting.Dictionary
 
Const sPROCNAME As String = "Table_DictionarySumByTwoColumns"
 
Dim dicFilterDictionary As Scripting.Dictionary
Dim scolumn1value_rows As String
Dim scolumn2value_columns As String
Dim sactualvalue As String
Dim sConCat As String
Dim larrayno As Long
Dim sngSUM As Single
Dim lAVERAGECOUNT As Long
 
   On Error GoTo ErrorHandler
  
   Set dicFilterDictionary = New Scripting.Dictionary
   Set dicUniqueColumn1_Rows = New Scripting.Dictionary
   Set dicUniqueColumn2_Columns = New Scripting.Dictionary
 
   For larrayno = 1 To UBound(vFilteredArray, 1)
      scolumn1value_rows = vFilteredArray(larrayno, lColumnNo1_Rows)
      scolumn2value_columns = vFilteredArray(larrayno, lColumnNo2_Columns)
 
      If ((scolumn1value_rows <> "") And (scolumn2value_columns <> "")) Then
 
         sactualvalue = vFilteredArray(larrayno, lColumnSumValue)
         If (sactualvalue <> "0") And (VBA.IsNumeric(sactualvalue) = True) Then
        
            sConCat = scolumn1value_rows & "#" & scolumn2value_columns
  
            If (dicUniqueColumn1_Rows.Exists(scolumn1value_rows) = False) Then
               dicUniqueColumn1_Rows.Add scolumn1value_rows, 0
            End If
  
            If (dicUniqueColumn2_Columns.Exists(scolumn2value_columns) = False) Then
               dicUniqueColumn2_Columns.Add scolumn2value_columns, 0
            End If
           
            If (dicFilterDictionary.Exists(sConCat) = False) Then
               If (bAddAverageCount = True) Then
                  lAVERAGECOUNT = 1
                  dicFilterDictionary.Add sConCat, CSng(sactualvalue) & "#" & lAVERAGECOUNT
               Else
                  dicFilterDictionary.Add sConCat, CSng(sactualvalue)
               End If
            Else
               If (bAddAverageCount = True) Then
                  lAVERAGECOUNT = VBA.Split(dicFilterDictionary.Item(sConCat), "#")(1)
                  sngSUM = VBA.Split(dicFilterDictionary.Item(sConCat), "#")(0)
                 
                  sngSUM = sngSUM + CSng(sactualvalue)
                  lAVERAGECOUNT = lAVERAGECOUNT + 1
                 
                  dicFilterDictionary.Item(sConCat) = sngSUM & "#" & lAVERAGECOUNT
                 
               Else
                  sngSUM = dicFilterDictionary.Item(sConCat)
                  sngSUM = sngSUM + CSng(sactualvalue)
                  dicFilterDictionary.Item(sConCat) = sngSUM
               End If
            End If
  
            dicUniqueColumn1_Rows.Item(scolumn1value_rows) = _
               dicUniqueColumn1_Rows.Item(scolumn1value_rows) + CSng(sactualvalue)
              
            dicUniqueColumn2_Columns.Item(scolumn2value_columns) = _
               dicUniqueColumn2_Columns.Item(scolumn2value_columns) + CSng(sactualvalue)
              
         End If
     
      End If
   Next larrayno
                                                            
   Set Table_DictionarySumByTwoColumns = dicFilterDictionary
  
   Exit Function
ErrorHandler:
   MsgBox (Err.Number & " - " & Err.Description)
'   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

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

Shades a block of data based on the changing values in a particular column.
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_SortCells_ByColumn

Public Sub Table_SortCells_ByColumn( _
         ByVal sWshName As String, _
         ByVal lColFirst As Long, _
         ByVal lRowFirst As Long, _
         ByVal lColLast As Long, _
         ByVal lRowLast As Long, _
         ByVal lSortColFirst As Long, _
         ByVal lSortRowFirst As Long, _
Optional ByVal bDescending As Boolean = True, _
Optional ByVal enHeader As XlYesNoGuess = XlYesNoGuess.xlYes)
 
Const sPROCNAME As String = "Table_SortCells_ByColumn"
 
Dim oStartCell As Range
Dim oFinishCell As Range
Dim oRange As Excel.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
 
   If (bDescending = True) Then
      Worksheets(sWshName).Range(spasterange).Sort _
          Key1:=Worksheets(sWshName).Cells(lSortRowFirst, lSortColFirst), _
          Order1:=xlDescending, _
          Header:=enHeader
   End If
   If (bDescending = False) Then
      Worksheets(sWshName).Range(spasterange).Sort _
          Key1:=Worksheets(sWshName).Cells(lSortRowFirst, lSortColFirst), _
          Order1:=xlAscending, _
          Header:=enHeader
   End If
  
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Table_SortNamedRange_ByColumn

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_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", "AVP 0", "Analyst 3", "Analyst 2", "Analyst 1")
 
   Worksheets(sWshName).Range(spasterange).Sort _
       Key1:=Worksheets(sWshName).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_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), _
       Order1:=xlAscending, _
       Key2:=Worksheets(sWshName).Cells(lRowSecond, lColSecond), _
       Order2:=xlAscending, _
       Header:=enHeader

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