数据透视表ShowDetail VBA仅选择SQL样式中的选定列

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 ie 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