PivotTable ShowDetail VBA выбрать только выбранные столбцы в стиле SQL

Question

Хотя показывающие детали сводной таблицы с помощью метода VBA:

Range("D10").ShowDetail = True 

Я хотел бы выбрать только те столбцы, которые я хочу, в указанном порядке, я хочу. Скажем, в исходных данных сводной таблицы у меня есть 10 столбцов (col1, col2, col3, ..., col10), а при расширении данных с помощью VBA я хочу показать всего 3 столбца (col7, col2, col5).

Можно ли сделать это в стиле SQL, как:

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

Answer 1

Да, я, наконец, сделал это. Эта коллекция из трех подстановок позволяет делать операторы SQL только что использованные ShowDetail на сводной таблице.

После запуска Range("D10").ShowDetail = True запустить макрос RunSQLstatementsOnExcelTable Просто настроить SQL в соответствии с вашими потребностями:

select [Col7],[Col2],[Col5] from [DetailsTable] where [Col7] is not null Просто оставьте [DetailsTable] как это. Он будет автоматически изменен на ActiveSheet с данными деталей.

Вызов дополнительного DeleteAllWhereColumnIsNull не является обязательным. Этот подход совпадает с delete from table WHERE Column is null в SQL, но он гарантирует, что ключевой столбец не потеряет форматирование. Ваше форматирование считывается из первых восьми строк, и оно будет преобразовано в текст, т. Е. Если у вас есть 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 

Answer 2

Я настраивал это как функция, так что вы можете получить ссылку на лист, как этот

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 

сканирование функции заголовков, которые будут возвращать массив с в строке: имя заголовка, в номер столбца, Column письмо:

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