Exportar un Query a Excel

[Santino]

Buen día, 

Tengo un problema tratando de importar los datos de un query de Acces a Excel para poder generar una tabla pivote, no tengo problema generando la tabla pivote, si no en la importación del query a excel mediante VBA.

El acercamiento que tuve fue con este código pero al tratar de llamarlo en el Sub, me aparece el error de hace falta un separador de listas o error de sintaxis, esta macro se ejecuta desde Access.

Option Compare Database
Sub PivotT()
SendTQ2Excel(strTQName As String, Optional strSheetName As String)
End Sub
Public Function SendTQ2Excel(strTQName As String, Optional strSheetName As String)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to name it to
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As DAO.Field
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    On Error GoTo err_handler
    Set rst = CurrentDb.OpenRecordset("SR_<-400")
    Set ApXL = CreateObject("Excel.Application")
    Set xlWBk = ApXL.Workbooks.Add
    ApXL.Visible = True
        
    Set xlWSh = xlWBk.Worksheets("DATA")
    If Len(strSheetName) > 0 Then
        xlWSh.Name = Left(strSheetName, 34)
    End If

    xlWSh.Activate
    xlWSh.Range("A1").Select

    For Each fld In rst.Fields
        ApXL.ActiveCell = fld.Name
        ApXL.ActiveCell.Offset(0, 1).Select
    Next
    rst.MoveFirst
    xlWSh.Range("A2").CopyFromRecordset rst
    xlWSh.Range("1:1").Select
    ' This is included to show some of what you can do about formatting.  You can comment out or delete
    ' any of this that you don't want to use in your own export.
    With ApXL.Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
    End With
    ApXL.Selection.Font.Bold = True
    With ApXL.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With
    ' selects all of the cells
    ApXL.ActiveSheet.Cells.Select
    ' does the "autofit" for all columns
    ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
    ' selects the first cell to unselect all cells
    xlWSh.Range("A1").Select
    rst.Close
    Set rst = Nothing
    Exit Function
err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Exit Function
End Function

 

[Gerson Pineda]

Hola

Es mas simple y sencillo, importar desde Excel con power query 

Realiza prueba con ese archivo

 

Saludos