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

用VBA方法显示pivottable的细节:

Range("D10").ShowDetail = True 

我想按照我想要的特定顺序只select我想要的列。 让我们说在数据透视表的源数据中,我有10列(col1,col2,col3,…,col10),同时用VBA展开细节我只想显示3列(col7,col2,col5)。

是否有可能做到这一点SQL样式:

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

我将其作为一个函数调整,以便您可以像这样获取图纸参考

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

这是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 

带有标题名称的解决scheme

结果将以ScanHeaders函数中string中设置的顺序显示

 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 

从Column的数字中获得Column的字母的函数是:

 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 

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

运行Range("D10").ShowDetail = True运行macrosRunSQLstatementsOnExcelTable只需根据需要调整SQL即可:

select [Col7],[Col2],[Col5] from [DetailsTable] where [Col7] is not null只需将[DetailsTable]原样即可。 它会自动更改为ActiveSheet与细节数据。

调用子DeleteAllWhereColumnIsNull是可选的。 这种方法与delete from table WHERE Column is null相同delete from table WHERE Column is null在SQL中delete from table WHERE Column is null ,但它保证了键列不会失去其格式。 你的格式是从前八行读取的,它会变成文本,即如果你在第一行有NULL。 有关ADO的损坏格式的更多信息,请参阅此处 。

您不必使用macros启用对ActiveX库的引用。 如果你想分发你的文件是非常重要的。

您可以尝试不同的连接string。 有三个不同的左边以防万一。 他们都为我工作。

 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