Option Explicit
'
'F: This entire module should be copied into an Excel workbook in the WB_ThisWorkbook module.
' This code was inspired by:
' http://www.mrexcel.com/forum/excel-questions/190025-pivot-table-drilldown-possibly-one-visual-basic-applications-gurus.html.
'
' A standard feature of pivot tables is "Show Details".
' If a pivot table has PivotTable options | Data | "Enable Show Details" on then:
' double click
' or
' right click | Show Details
' to copy the data behind that cell into a new detail (or drilldown) worksheet.
'
' A workbook can quickly become cluttered with drilldown sheets and it is not immediately apparent
' where the data came from.
'
' In my application, the pivot details are a summary of another sheet.
'
' If the pivot table sheet name ends in "_Pivot", then:
' a single drilldown sheet per pivot sheet is used.
' the drilldown sheet name has "_Pivot" replaced by "_DD".
' a header describes where the data came from.
' the drilldown sheet has frozen columns as per the data source
' (not the pivot table - the source of the pivot).
' the drilldown data is sorted in the frozen columns
' as expect the source data is sorted in frozen columns.
' if a drilldown cell in the leftmost column is clicked, the data range in Milestone_Detail is highlighted.
' actual name is in the constant strDetail_Sheet.
' if other than the left most column is clicked, and it is non blank, deletion of that range of details is offered.
' simply change the pivot table sheet name if you don't like this. (I use a dot at the end.)
'
' This code handles multiple pivot tables (each in its own sheet).
'
' Directory
' =========
' Workbook_NewSheet
' Workbook_NewSheet_A
' Workbook_SheetBeforeDoubleClick
' SheetExists
' FindAll
' FindAll_Test
' Sort_Rows
'
Public xlrngCurrent As Excel.Range
Const strTagDrillDown As String = "_DD"
Const strTagPivot As String = "_Pivot"
' Const blnUse_SheetName As Boolean = False ' Use Pivot Table name.
Const blnUse_SheetName As Boolean = True ' Use Sheet name.
Const strDetail_Sheet As String = "Milestone_Detail"
Const intDebug As Integer = 0 ' No debugging.
' Const intDebug As Integer = 1 ' Standard debugging.
' Const intDebug As Integer = 2 ' Detailed debugging.
Public Sub Workbook_NewSheet(ByVal Sh As Object)
'
' F: Excel event procedure run after new sheet is created.
' Must reside in ThisWorkbook module of an Excel workbook to function.
' Name cannot be changed.
' Signature cannot be changed.
' Stated another way: Parameter declarations cannot be changed in any way.
'
' Jacket for Workbook_NewSheet_A.
'
' I: Sh New sheet.
'
Dim xlrngActiveCell As Excel.Range
Dim strDetail As String
Const strWho As String = "Workbook_NewSheet"
If intDebug >= 2 Then
Debug.Print strWho & " ActiveSheet.Name=" & ActiveSheet.Name
Debug.Print strWho & " New Sheet.Name=" & Sh.Name
End If
If intDebug >= 2 Then
On Error Resume Next
Debug.Print strWho & " " & xlrngCurrent.Address(External:=True)
Set xlrngActiveCell = ActiveCell
Debug.Print strWho & " ActiveCell.Address=" & xlrngActiveCell.Address(External:=True)
' These pivot attributes will be invalid since they point to a new sheet.
strDetail = ActiveCell.PivotCell.ColumnItems.Item(1).DataRange
If Err.Number <> 0 Then strDetail = "<null>"
Debug.Print strWho & " PivotCell.ColumnItems.DataRange=" & strDetail
If Err.Number <> 0 Then strDetail = "<null>"
strDetail = ActiveCell.PivotCell.ColumnItems.Item(1).ParentItem.Caption
If Err.Number <> 0 Then strDetail = "<null>"
Debug.Print strWho & " PivotCell.ParentItem.Caption=" & strDetail
strDetail = xlrngActiveCell.PivotItem.Name
If Err.Number <> 0 Then strDetail = "<null>"
Debug.Print strWho & " PivotItem=" & strDetail
strDetail = xlrngActiveCell.PivotField.Name
If Err.Number <> 0 Then strDetail = "<null>"
Debug.Print strWho & " PivotField=" & strDetail
strDetail = xlrngActiveCell.PivotTable.Name
If Err.Number <> 0 Then strDetail = "<null>"
Debug.Print strWho & " PivotTable=" & strDetail
On Error GoTo 0
End If
Call Workbook_NewSheet_A(Sh:=Sh)
End Sub ' Workbook_NewSheet.
Public Sub Workbook_NewSheet_A(ByVal Sh As Object)
'
' F: When a cell in a pivot table is double clicked, Excel:
' creates a new sheet
' copies the data that is behind the pivotcell to the new sheet
' Code here calls the new sheet the Drilldown sheet.
' invokes Workbook_NewSheet VBA subroutine:
' That subroutine calls this code.
' This code creates the Drilldown sheet if required (and copies frozen columns specification).
' This code copies and sorts the data to the Drilldown sheet.
' This code deletes the new sheet.
'
' When VBA deletes the new sheet, then Excel, by default, returns to the sheet it was in previously,
' i.e. the one you double clicked in.
'
' From:
' http://www.mrexcel.com/forum/excel-questions/190025-pivot-table-drilldown-possibly-one-visual-basic-applications-gurus.html
'
' G: xlrngCurrent See Workbook_SheetBeforeDoubleClick.
'
Dim xlrngActiveCell As Excel.Range
Dim numBang As Long
Dim strClickedSheet As String
Dim numCol_Criteria As Integer
Dim strDrillDown As String ' Accumulated drill downs.
Dim xlwsDrillDown As Excel.Worksheet ' Accumulated drill downs.
Dim numI As Integer
Dim xlwsNascentSheet As Excel.Worksheet ' The just created sheet.
Dim xlpvcPivotCell As Excel.PivotCell
Dim blnPivotSheet As Boolean
Dim numRow_Criteria As Integer
Dim numRows As Long
Dim xlwsSourceSheet As Excel.Worksheet
Dim numSplitColumn As Long
Dim numSplitRow As Long
Dim strWhere_From As String
Dim y(1 To 3) As Integer
Const strWho As String = "Workbook_NewSheet_A"
'˜Const intDebug As Integer = 2 ' If commented, use global.
If xlrngCurrent Is Nothing Then
Exit Sub
End If
strClickedSheet = xlrngCurrent.Parent.Name ' Sheet when clicked via global. See Workbook_SheetBeforeDoubleClick.
If strClickedSheet <> "" Then
Set xlwsNascentSheet = ActiveSheet
If blnUse_SheetName Then
If Right(strClickedSheet, Len(strTagPivot)) = strTagPivot Then
blnPivotSheet = True
End If
Else
If strClickedSheet = xlrngCurrent.PivotTable.Name Then
If strClickedSheet <> "" Then
blnPivotSheet = True
Else
blnPivotSheet = False
End If
End If
End If
If intDebug >= 2 Then
Debug.Print strWho & ": blnPivotSheet=" & blnPivotSheet
End If
If Not blnPivotSheet Then
Set xlrngCurrent = Nothing
Exit Sub
End If
' Given the sheetname-when-clicked, get drilldown sheet name.
strDrillDown = Left(strClickedSheet, Len(strClickedSheet) - Len(strTagPivot)) & strTagDrillDown
If intDebug >= 2 Then
Debug.Print strWho & " DrillDown=" & strDrillDown
End If
With ActiveSheet.Application
If intDebug >= 2 Then
Debug.Print strWho & ": SourceName=" & xlrngCurrent.PivotCell.DataField.SourceName
Debug.Print strWho & ": SourceData=" & xlrngCurrent.PivotCell.PivotTable.SourceData
End If
' Get source sheet so can freeze/sort columns on the Drilldown.
numBang = InStr(1, xlrngCurrent.PivotCell.PivotTable.SourceData, "!")
Set xlwsSourceSheet = .Worksheets(Left(xlrngCurrent.PivotCell.PivotTable.SourceData, numBang - 1))
.ScreenUpdating = False
If SheetExists(strWorksheet:=strDrillDown) Then
Set xlwsDrillDown = .Sheets(strDrillDown)
Else
' Need to be careful:
' we are here because a new sheet, the nascent sheet, has been added.
' we do not have a drilldown sheet.
' we want to add a new sheet (for the drill down), but we don't want this very code to run
' for that sheet.
' Therefore, disable events and reenable after adding the sheet.
.EnableEvents = False
Set xlwsDrillDown = ActiveSheet.Application.Sheets.Add(After:=Sheets(strClickedSheet))
' Reenable.
.EnableEvents = True
xlwsDrillDown.Name = strDrillDown
' Transfer frozen columns.
xlwsSourceSheet.Activate ' Activate the source sheet of the clicked sheet.
With ActiveWindow
If (.SplitRow = 0) And (.SplitColumn = 0) Then
' Nothing to do - not frozen.
Else
numSplitColumn = .SplitColumn
numSplitRow = .SplitRow
xlwsDrillDown.Activate
With ActiveWindow
.SplitColumn = numSplitColumn
.SplitRow = numSplitRow
.FreezePanes = True
End With
End If
End With
End If
With xlwsDrillDown
If WorksheetFunction.CountA(.Rows(1)) = 0 Then
numRows = 1
Else
numRows = .Cells.Find(What:="*", _
After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 2
End If
If False Then
xlwsNascentSheet.Range("A1").CurrentRegion.Copy Destination:=.Cells(numRows, 1)
Else
xlwsNascentSheet.Range("A1").CurrentRegion.Copy
With xlwsDrillDown.Cells(numRows, 1)
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
.PasteSpecial Paste:=xlPasteColumnWidths
End With
With .Cells(numRows, 1) _
.Resize(RowSize:=xlwsNascentSheet.Range("A1").CurrentRegion.Rows.Count, _
ColumnSize:=xlwsNascentSheet.Range("A1").CurrentRegion.Columns.Count)
xlwsSourceSheet.Activate ' Activate the source sheet of the clicked sheet.
If ActiveWindow.SplitColumn > 0 Then
'Stop
Sort_Rows numColumns:=ActiveWindow.SplitColumn - 1, _
numLeft_Column:=1, _
xlrngTarget:=.CurrentRegion ' Includes header.
End If
End With
End If
If intDebug >= 1 Then
Debug.Print strWho & " CurrentRegion.Address=" & _
xlwsNascentSheet.Range("A1").CurrentRegion.Address(External:=True)
End If
End With
.DisplayAlerts = False
xlwsNascentSheet.Delete
.DisplayAlerts = True
Set xlrngActiveCell = xlrngCurrent ' Copy global, which cannot be seen in debugger, to local, which can.
If intDebug >= 1 Then
Debug.Print strWho & " xlrngCurrent.Address=" & xlrngCurrent.Address(External:=True)
Debug.Print strWho & " xlrngActiveCell.Address=" & xlrngActiveCell.Address(External:=True)
End If
Set xlpvcPivotCell = xlrngCurrent.PivotCell
numCol_Criteria = xlpvcPivotCell.ColumnItems.Count
numRow_Criteria = xlpvcPivotCell.RowItems.Count
If intDebug >= 1 Then
Debug.Print strWho & " Row_Criteria=" & numRow_Criteria & " Col_Criteria=" & numCol_Criteria
Debug.Print strWho & " .ColumnItems(1)=" & xlrngCurrent.PivotCell.ColumnItems.Item(1).Name
End If
strWhere_From = ""
If numRow_Criteria > 0 Then
strWhere_From = strWhere_From & " Row"
For numI = 1 To numRow_Criteria
strWhere_From = strWhere_From & " [" & xlpvcPivotCell.RowItems.Item(numI) & "]"
Next numI
End If
y(1) = Len(strWhere_From)
If numCol_Criteria > 0 Then
strWhere_From = strWhere_From & " / Column"
For numI = 1 To numCol_Criteria
strWhere_From = strWhere_From & " [" & xlpvcPivotCell.ColumnItems.Item(numI) & "]"
Next numI
End If
y(2) = Len(strWhere_From)
strWhere_From = strWhere_From & " from Sheet " & ActiveSheet.Name
y(3) = Len(strWhere_From)
xlwsDrillDown.Select
xlwsDrillDown.Cells(numRows, 1).EntireRow.Interior.ColorIndex = xlColorIndexNone
xlwsDrillDown.Cells(numRows, 1).EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Value = strWhere_From
With ActiveCell.Characters.Font
.Name = "Arial"
.FontStyle = "Bold Italic"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With ActiveCell.Characters(Start:=1, Length:=y(1)).Font
.Color = -16776961 ' Red=255, Green=1, Blue=1. - Port.
End With
With ActiveCell.Characters(Start:=y(1) + 1, Length:=y(2) - y(1)).Font
.Color = -11489280 ' Red=0, Green=176, Blue=81. - Starboard.
End With
With ActiveCell.Characters(Start:=y(2) + 1, Length:=y(3) - y(2)).Font
.Color = -4165632 ' Red=0, Green=112, Blue=193.
End With
.ScreenUpdating = True
End With
End If
Set xlrngCurrent = Nothing
End Sub ' Workbook_NewSheet_A.
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'
' F: Excel event procedure for any worksheet in workbook before double click.
' Must reside in ThisWorkbook module of an Excel workbook to function.
' Name cannot be changed.
' Signature cannot be changed.
'
' G: xlrngCurrent
'
Dim intCancel As Integer
Dim blnDrillDownSheet As Boolean
Dim intErr_Number As Integer
Dim xlrngFound As Excel.Range
Dim strPivotTable As String
Dim xlrngSearch As Excel.Range
Dim strValue As String
Const strWho As String = "Workbook_SheetBeforeDoubleClick"
' Const intDebug As Integer = 1 ' If commented, use global.
Set xlrngCurrent = Nothing ' Make sure no dangling reference.
If Right(Target.Parent.Name, Len(strTagDrillDown)) = strTagDrillDown Then
blnDrillDownSheet = True
End If
If intDebug >= 1 Then
Debug.Print strWho & ": Target.Address=" & Target.Address(External:=True)
Debug.Print strWho & ": ActiveCell.Address=" & ActiveCell.Address(External:=True)
Debug.Print strWho & ": blnDrillDownSheet=" & blnDrillDownSheet
End If
If blnDrillDownSheet Then
If ActiveCell.Column = 1 Then
' Left-most column on drilldown sheet.
' Find history of summary item.
If strDetail_Sheet = "" Then
Exit Sub
End If
strValue = ActiveCell.Value
If SheetExists(strWorksheet:=strDetail_Sheet) Then
Set xlrngSearch = Range(strDetail_Sheet)
Else
ActiveCell.Application.StatusBar = "Sheet " & strDetail_Sheet & " does not exist"
Exit Sub
End If
If intDebug >= 2 Then
Debug.Print strWho & ": Search.Address=" & xlrngSearch.Address(External:=True)
Debug.Print strWho & ": Search.Address=" & xlrngSearch.Resize(ColumnSize:=1).Address(External:=True)
End If
Set xlrngFound = FindAll(SearchRange:=xlrngSearch.Resize(ColumnSize:=1), _
FindWhat:=strValue, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare, _
intDebug:=intDebug)
If xlrngFound Is Nothing Then
If intDebug >= 1 Then
Debug.Print strWho & ": Value Not Found=""" & strValue & """"
End If
Else
If intDebug >= 1 Then
Debug.Print strWho & ": Found.Address=" & xlrngFound.Address(External:=True)
End If
xlrngFound.Application.Goto _
Reference:=xlrngFound.Resize(ColumnSize:=xlrngSearch.Columns.Count), _
scroll:=True
End If
Exit Sub
End If
If ActiveCell.Value <> "" Then
intCancel = MsgBox("Delete this detailed data?", vbYesNo)
If intCancel = vbNo Then
' Keep the data.
Exit Sub
End If
' Delete region.
With Target.CurrentRegion
.Resize(.Rows.Count + 1).EntireRow.Delete
End With
End If
If intDebug >= 2 Then
Debug.Print strWho & ": Old Selection.Address=" & Selection.Address(External:=True)
End If
If intDebug >= 1 Then
Debug.Print strWho & ": New Selection.Address=" & Selection.Address(External:=True)
End If
Else
' Not a drilldown sheet.
On Error Resume Next
strPivotTable = Target.PivotTable.Name
On Error GoTo 0
If strPivotTable <> "" Then
' Within a pivot table.
If blnUse_SheetName Then
If Right(Target.Parent.Name, Len(strTagPivot)) = strTagPivot Then
' Save target in a global variable, so enable detail processing.
Set xlrngCurrent = Target
End If
Else
Set xlrngCurrent = Target ' Save target in a global variable, so enable detail processing.
End If
' After the doubleclick (a.k.a. the reason for being in this sub), Excel will create a new
' sheet and call Workbook_NewSheet.
End If
End If
End Sub ' Workbook_SheetBeforeDoubleClick.
Function SheetExists(strWorksheet As String, Optional xlWbWorkBook As Excel.Workbook = Nothing) As Boolean
'
' F: Checks whether a worksheet exists.
' From:
' http://stackoverflow.com/questions/11776353/rename-worksheet-name-based-on-pivot-drill-with-vba.
'
' I: strWorksheet Worksheet name to check.
' xlWbWorkBook Workbook to check. Defaults to ThisWorkbook.
'
' O: <result>
' True => Exists
'
SheetExists = False
Dim xlwsWorkSheet As Excel.Worksheet
If xlWbWorkBook Is Nothing Then Set xlWbWorkBook = ThisWorkbook
On Error Resume Next
Set xlwsWorkSheet = xlWbWorkBook.Worksheets(strWorksheet)
On Error GoTo 0
If Not xlwsWorkSheet Is Nothing Then SheetExists = True
End Function ' SheetExists.
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As Excel.XlFindLookIn = xlValues, _
Optional LookAt As Excel.XlLookAt = xlWhole, _
Optional SearchOrder As Excel.XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare, _
Optional intDebug As Integer = 1) As Range
'
' F: This searches the range specified by SearchRange and returns a Range object that contains all the
' cells in which FindWhat was found.
' The search parameters to this function have the same meaning and effect as they do with the
' Range.Find method.
' If the value was not found, the function returns Nothing.
' If BeginsWith is not an empty string, only those cells that begin with BeginsWith are included in
' the result.
' If EndsWith is not an empty string, only those cells that end with EndsWith are included in the
' result.
' Note that if a cell contains a single word that matches either BeginsWith or EndsWith, it is
' included in the result.
' If BeginsWith or EndsWith is not an empty string, the LookAt parameter is automatically changed to
' xlPart.
' The tests for BeginsWith and EndsWith may be case-sensitive by setting BeginEndCompare to
' vbBinaryCompare.
' For case-insensitive comparisons, set BeginEndCompare to vbTextCompare.
' If this parameter is omitted, it defaults to vbTextCompare.
' The comparisons for BeginsWith and EndsWith are in an OR relationship. That is, if both BeginsWith
' and EndsWith are provided, a match if found if the text begins with BeginsWith OR the text ends
' with EndsWith.
'
' From:
' http://www.cpearson.com/excel/FindAll.aspx.
'
' T: FindAll_Test
'
Dim FoundCell As Excel.Range
Dim FirstFound As Excel.Range
Dim LastCell As Excel.Range
Dim ResultRange As Excel.Range
Dim XLookAt As Excel.XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Excel.Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
Const strWho As String = "FindAll"
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' This loop in Areas is to find the last cell of all the areas.
' That is, the cell whose row and column are greater than or equal to any cell in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(What:=FindWhat, _
After:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
If intDebug >= 1 Then
Debug.Print strWho & " FirstFound.Address=" & FirstFound.Address(External:=True)
End If
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = SearchRange.Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(After:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function ' FindAll.
Sub FindAll_Test()
'
' F: Test for FindAll.
'
' T: FindAll_Test
'
Dim SearchRange As Excel.Range
Dim FindWhat As Variant
Dim FoundCells As Excel.Range
Dim FoundCell As Excel.Range
Const strWho As String = "FindAll_Test"
Const intDebug As Integer = 1
Set SearchRange = Range(strDetail_Sheet & "!A1:A40")
If intDebug >= 1 Then
Debug.Print strWho & " SearchRange.Address=" & SearchRange.Address(External:=True)
End If
FindWhat = "Test-Target"
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare, _
intDebug:=intDebug)
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
For Each FoundCell In FoundCells
Debug.Print "Value Found In Cell: " & FoundCell.Address(False, False)
Next FoundCell
End If
End Sub ' FindAll_Test.
Function Sort_Rows(numColumns As Integer, numLeft_Column As Long, xlrngTarget As Excel.Range) As Boolean
'
' F: Sorts a range by columns.
' For simplicity, columns are contiguous.
' Handles upto and including 5 keys.
'
' I: numColumns Number of columns to sort.
' numLeft_Column Left column for sort.
' xlrngTarget Range to sort.
'
' O: <result> Error indicator.
' True => Error.
'
Const strWho As String = "Sort_Rows"
If intDebug >= 1 Then
Debug.Print strWho & ": Target.Address=" & xlrngTarget.Address(External:=True)
Debug.Print strWho & ": Target.Columns(Left_Column).Address=" & xlrngTarget.Columns(numLeft_Column + 0).Address(External:=True)
End If
'xlrngTarget.Sort key1:=xlrngTarget.Columns(numLeft_Column).Resize(ColumnSize:=numColumns), order1:=xlAscending, Header:=xlYes
With xlrngTarget
If numColumns = 1 Then
.Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, Header:=xlYes
ElseIf numColumns = 2 Then
.Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, _
key2:=.Columns(numLeft_Column + 1), order2:=xlAscending, _
Header:=xlYes
ElseIf numColumns = 3 Then
.Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, _
key2:=.Columns(numLeft_Column + 1), order2:=xlAscending, _
key3:=.Columns(numLeft_Column + 2), order3:=xlAscending, _
Header:=xlYes
ElseIf numColumns = 4 Then
' Since sort is stable, can sort by the fourth key and then the other three.
.Sort key1:=.Columns(numLeft_Column + 3), order1:=xlAscending, Header:=xlYes
.Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, _
key2:=.Columns(numLeft_Column + 1), order2:=xlAscending, _
key3:=.Columns(numLeft_Column + 2), order3:=xlAscending, _
Header:=xlYes
ElseIf numColumns = 5 Then
' Since sort is stable, can sort by the fourth and fifth keys and then the other three.
.Sort key1:=.Columns(numLeft_Column + 3), order1:=xlAscending, _
key2:=.Columns(numLeft_Column + 4), order2:=xlAscending, _
Header:=xlYes
.Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, _
key2:=.Columns(numLeft_Column + 1), order2:=xlAscending, _
key3:=.Columns(numLeft_Column + 2), order3:=xlAscending, _
Header:=xlYes
Else
MsgBox Prompt:=strWho & ": Too many sort keys for table " & xlrngTarget.Name
Sort_Rows = True
Stop
End If
End With
End Function ' Sort_Rows.
