PivotTable ShowDetail VBA choose only selected columns in SQL style - vba

Question

While showing details of pivottable with VBA method:
Range("D10").ShowDetail = True
I would like to choose only the columns I want, in a specified order I want. Let's say in source data of pivot table I have 10 columns (col1, col2, col3, ... , col10), and while expanding details with VBA I want to show just 3 columns (col7, col2, col5).
Is it possible to do it in SQL style like:
SELECT col7, col2, col5 from Range("D10").ShowDetail

Answer 1

I tuned this as a function so that you can get the sheet reference like this
Set DetailSheet = test_Przemyslaw_Remin(Range("D10"))
Here is the function :
Public Function test_Przemyslaw_Remin(RangeToDetail As Range) As Worksheet
Dim Ws As Worksheet
RangeToDetail.ShowDetail = True
Set Ws = ActiveSheet
Ws.Range("A1").Select
Ws.Columns("H:J").Delete
Ws.Columns("F:F").Delete
Ws.Columns("C:D").Delete
Ws.Columns("A:A").Value = Ws.Columns("D:D").Value
Ws.Columns("D:D").Clear
Set test_Przemyslaw_Remin = Ws
End Function
Solution with Headers' names
Results will be shown in the order set in the string in the ScanHeaders function
Public Sub SUB_Przemyslaw_Remin(RangeToDetail As Range)
Dim Ws As Worksheet, _
MaxCol As Integer, _
CopyCol As Integer, _
HeaD()
RangeToDetail.ShowDetail = True
Set Ws = ActiveSheet
HeaD = ScanHeaders(Ws, "HeaderName1/HeaderName2/HeaderName3")
For i = LBound(HeaD, 1) To UBound(HeaD, 1)
If HeaD(i, 2) > MaxCol Then MaxCol = HeaD(i, 2)
Next i
With Ws
.Range("A1").Select
.Columns(ColLet(MaxCol + 1) & ":" & ColLet(.Columns.Count)).Delete
'To start filling the data from the next column and then delete what is before
CopyCol = MaxCol + 1
For i = LBound(HeaD, 1) To UBound(HeaD, 1)
.Columns(ColLet(CopyCol) & ":" & ColLet(CopyCol)).Value = _
.Columns(HeaD(i, 3) & ":" & HeaD(i, 3)).Value
CopyCol = CopyCol + 1
Next i
.Columns("A:" & ColLet(MaxCol)).Delete
End With
End Sub
The scan headers function, that will return a array with in row : Header's Name,
Column number, Column letter :
Public Function ScanHeaders(aSheet As Worksheet, Headers As String, Optional Separator As String = "/") As Variant
Dim LastCol As Integer, _
ColUseName() As String, _
ColUse()
ColUseName = Split(Headers, Separator)
ReDim ColUse(1 To UBound(ColUseName) + 1, 1 To 3)
For i = 1 To UBound(ColUse)
ColUse(i, 1) = ColUseName(i - 1)
Next i
With Sheets(SheetName)
LastCol = .Cells(1, 1).End(xlToRight).Column
For k = LBound(ColUse, 1) To UBound(ColUse, 1)
For i = 1 To LastCol
If .Cells(1, i) <> ColUse(k, 1) Then
If i = LastCol Then MsgBox "Missing data : " & ColUse(k, 1), vbCritical, "Verify data integrity"
Else
ColUse(k, 2) = i
Exit For
End If
Next i
ColUse(k, 3) = ColLet(ColUse(k, 2))
Next k
End With
ScanHeaders = ColUse
End Function
And the function to get the Column's letter from the Column's number :
Public Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function

Answer 2

Yes, I have finally done it. This collection of three subs allows you make SQL statements on just used ShowDetail on PivotTable.
After running Range("D10").ShowDetail = True run macro RunSQLstatementsOnExcelTable
Just adjust the SQL according to your needs:
select [Col7],[Col2],[Col5] from [DetailsTable] where [Col7] is not null
Just leave [DetailsTable] as it is. It will be changed automatically into ActiveSheet with details data.
Calling the sub DeleteAllWhereColumnIsNull is optional. This approach is the same as delete from table WHERE Column is null in SQL but it guarantees that the key column will not lose its formatting. Your formatting is read from the first eight rows and it will be turned into text i.e. if you have NULLs in the first rows. More about corrupt formatting of ADO you may find here.
You do not have to enable references to ActiveX libraries using the macros. It is important if you want to distribute your files.
You may experiment with different connection strings. There are three different left just in case. All of them worked for me.
Sub RunSQLstatementsOnExcelTable()
Call DeleteAllWhereColumnIsNull("Col7") 'Optionally delete all rows with empty value on some column to prevent formatting issues
'In the SQL statement use "from [DetailsTable]"
Dim SQL As String
SQL = "select [Col7],[Col2],[Col5] from [DetailsTable] where [Col7] is not null order by 1 desc" '<-- Here goes your SQL code
Call SelectFromDetailsTable(SQL)
End Sub
Sub SelectFromDetailsTable(ByVal SQL As String)
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.UsedRange.Select 'This stupid line proved to be crucial. If you comment it, then you may get error in line oRS.Open
Dim InputSheet, OutputSheet As Worksheet
Set InputSheet = ActiveSheet
Worksheets.Add
DoEvents
Set OutputSheet = ActiveSheet
Dim oCn As Object
Set oCn = CreateObject("ADODB.Connection")
Dim cmd As Object
Set cmd = CreateObject("ADODB.Command")
Dim oRS As Object
Set oRS = CreateObject("ADODB.Recordset")
Dim strFile As String
strFile = ThisWorkbook.FullName
'------- Choose whatever connection string you like, all of them work well -----
Dim ConnString As String
ConnString = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & strFile & ";HDR=Yes';" 'works good
'ConnString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";" 'IMEX=1 data as text
'ConnString = "Provider=Microsoft.Jet.OLEDB.4.0;excel 8.0;DATABASE=" & strFile 'works good
'ConnString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & strFile 'works good
Debug.Print ConnString
oCn.ConnectionString = ConnString
oCn.Open
'Dim SQL As String
SQL = Replace(SQL, "[DetailsTable]", "[" & InputSheet.Name & "$] ")
Debug.Print SQL
oRS.Source = SQL
oRS.ActiveConnection = oCn
oRS.Open
OutputSheet.Activate
'MyArray = oRS.GetRows
'Debug.Print MyArray
'----- Method 1. Copy from OpenRowSet to Range ----------
For intFieldIndex = 0 To oRS.Fields.Count - 1
OutputSheet.Cells(1, intFieldIndex + 1).Value = oRS.Fields(intFieldIndex).Name
Next intFieldIndex
OutputSheet.Cells(2, 1).CopyFromRecordset oRS
ActiveSheet.ListObjects.Add(xlSrcRange, Application.ActiveSheet.UsedRange, , xlYes).Name = "MyTable"
'ActiveSheet.ListObjects(1).Range.EntireColumn.AutoFit
ActiveSheet.UsedRange.EntireColumn.AutoFit
'----- Method 2. Copy from OpenRowSet to Table ----------
'This method sucks because it does not prevent losing formatting
'Dim MyListObject As ListObject
'Set MyListObject = OutputSheet.ListObjects.Add(SourceType:=xlSrcExternal, _
'Source:=oRS, LinkSource:=True, _
'TableStyleName:=xlGuess, destination:=OutputSheet.Cells(1, 1))
'MyListObject.Refresh
If oRS.State <> adStateClosed Then oRS.Close
If Not oRS Is Nothing Then Set oRS = Nothing
If Not oCn Is Nothing Then Set oCn = Nothing
'remove unused ADO connections
Dim conn As WorkbookConnection
For Each conn In ActiveWorkbook.Connections
Debug.Print conn.Name
If conn.Name Like "Connection%" Then conn.Delete 'In local languages the default connection name may be different
Next conn
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Sub DeleteAllWhereColumnIsNull(ColumnName As String)
Dim RngHeader As Range
Debug.Print ActiveSheet.ListObjects(1).Name & "[[#Headers],[" & ColumnName & "]]"
Set RngHeader = Range(ActiveSheet.ListObjects(1).Name & "[[#Headers],[" & ColumnName & "]]")
Debug.Print RngHeader.Column
Dim ColumnNumber
ColumnNumber = RngHeader.Column
ActiveSheet.ListObjects(1).Sort.SortFields.Clear
ActiveSheet.ListObjects(1).HeaderRowRange(ColumnNumber).Interior.Color = 255
ActiveSheet.ListObjects(1).ListColumns(ColumnNumber).DataBodyRange.NumberFormat = "#,##0.00"
With ActiveSheet.ListObjects(1).Sort
With .SortFields
.Clear
'.Add ActiveSheet.ListObjects(1).HeaderRowRange(ColumnNumber), SortOn:=xlSortOnValues, Order:=sortuj
.Add RngHeader, SortOn:=xlSortOnValues, Order:=xlAscending
End With
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Delete from DetailsTable where [ColumnName] is null
On Error Resume Next 'If there are no NULL cells, just skip to next row
ActiveSheet.ListObjects(1).ListColumns(ColumnNumber).DataBodyRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Err.Clear
ActiveSheet.UsedRange.Select 'This stupid thing proved to be crucial. If you comment it, then you will get error with Recordset Open
End Sub

Answer 3

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim PTCll As PivotCell
On Error Resume Next
Set PTCll = Target.PivotCell
On Error GoTo 0
If Not PTCll Is Nothing Then
If PTCll.PivotCellType = xlPivotCellValue Then
Cancel = True
Target.ShowDetail = True
With ActiveSheet
ActiveSheet.Range("A1").Select
ActiveSheet.Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Columns("E:F").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Columns("F:I").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Columns("J:R").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Columns("H:I").Select
Selection.NumberFormat = "0.00"
ActiveSheet.Columns("H:I").EntireColumn.AutoFit
Selection.NumberFormat = "0.0"
Selection.NumberFormat = "0"
ActiveSheet.Cells.Select
ActiveSheet.Cells.EntireColumn.AutoFit
ActiveSheet.Range("A1").Select
End With
End If
End If
End Sub