【问题标题】：PivotTable ShowDetail VBA choose only selected columns in SQL style数据透视表 ShowDetail VBA 仅选择 SQL 样式中的选定列
【发布时间】：2018-04-27 20:18:45
【问题描述】：

同时使用 VBA 方法显示数据透视表的详细信息：

Range("D10").ShowDetail = True

我只想按照我想要的指定顺序选择我想要的列。假设在数据透视表的源数据中，我有 10 列（col1、col2、col3、...、col10），而在使用 VBA 扩展细节时，我只想显示 3 列（col7、col2、col5）。

是否可以用 SQL 风格来做：

SELECT col7, col2, col5 from Range("D10").ShowDetail

【问题讨论】：

不，或者至少我不知道。您必须删除新工作表中不需要的列，然后移动其余列以适合您的订单！ ;)

标签： vba excel pivot-table

【解决方案1】：

我将其调整为一个函数，以便您可以像这样获得工作表参考

Set DetailSheet = test_Przemyslaw_Remin(Range("D10"))

这里是函数：

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

标题名称的解决方案

结果将按照ScanHeaders函数中字符串中设置的顺序显示

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

扫描标题函数，它将返回一个数组，其中包含行：标题的名称，列号、列字母：

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

以及从列号中获取列号的函数：

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

【讨论】：

我正在寻找带有列标题的解决方案。目前，我使用.EntireColumn.Hidden = True 而不是.Delete 的类似方法。我有一百列，如果外部数据源发生变化，那么对 H:J 等列的引用就变得毫无用处。不管怎样，谢谢你的回答。
我猜你已经下地狱从魔鬼本人那里得到这个解决方案。感谢您的巨大努力。我会检查你的代码。到目前为止，我一直在考虑一些基于 QueryTables 或 ListObjects 的更简单的方法，稍后可以用 SQL 语句对其进行质疑。这只是方向：technet.microsoft.com/en-us/library/ee692882.aspx
感谢阅读推荐，看起来确实很有趣！ ;) 无论如何，我希望这段代码能满足你目前的需要！ ;)
无论如何还是有用的。我不知道我们可以有一个工作表作为函数的结果:-)。检查这个进一步的方向：stackoverflow.com/questions/19755396/…

【解决方案2】：

是的，我终于做到了。这三个子集合允许您在数据透视表上刚刚使用的ShowDetail 上创建 SQL 语句。

运行Range("D10").ShowDetail = True后运行宏RunSQLstatementsOnExcelTable 只需根据您的需要调整 SQL：

select [Col7],[Col2],[Col5] from [DetailsTable] where [Col7] is not null 保持原样离开[DetailsTable]。它将自动更改为带有详细信息的 ActiveSheet。

调用子DeleteAllWhereColumnIsNull 是可选的。这种方法与 SQL 中的delete from table WHERE Column is null 相同，但它保证键列不会丢失其格式。您的格式是从前八行读取的，它将转换为文本，即如果您在第一行中有 NULL。有关 ADO 损坏格式的更多信息，您可以找到 here。

您不必使用宏启用对 ActiveX 库的引用。如果您想分发文件，这一点很重要。

您可以尝试不同的连接字符串。为了以防万一，剩下三个不同的。他们都为我工作。

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

【讨论】：

【解决方案3】：

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 将 PTCll 调暗为 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

结束子

【讨论】：