Exportation de données powerpivot vers csv

Question

J'ai un classeur Excel avec des données powerpivot dans le modèle de données Excel. Je n'ai pas le fichier utilisé pour importer les données dans powerpivot. Mon but est de sortir les données de powerpivot vers un csv pour pouvoir l'utiliser dans d'autres logiciels.

Je ne trouve aucune option d'exportation directe dans PowerPivot et comme les données sont plus grandes que 1,1M lignes, il ne peut pas être poussé dans Excel.

J'ai trouvé ce VBA qui semble fonctionner pour les fichiers plus petits mais pour les plus gros, j'ai une erreur de timeout.

Option Explicit 

Public Sub ExportToCsv() 

    Dim wbTarget As Workbook 
    Dim ws As Worksheet 
    Dim rs As Object 
    Dim sQuery As String 

    'Suppress alerts and screen updates 
    With Application 
     .ScreenUpdating = False 
     .DisplayAlerts = False 
    End With 

    'Bind to active workbook 
    Set wbTarget = ActiveWorkbook 

    Err.Clear 

    On Error GoTo ErrHandler 

    'Make sure the model is loaded 
    wbTarget.Model.Initialize 

    'Send query to the model 
    sQuery = "EVALUATE 'combine 2010 - Q2 2015'" 
    Set rs = CreateObject("ADODB.Recordset") 
    rs.Open sQuery, wbTarget.Model.DataModelConnection.ModelConnection.ADOConnection 
    Dim CSVData As String 
    CSVData = RecordsetToCSV(rs, True) 

    'Write to file 
    Open "D:\tempMyFileName.csv" For Binary Access Write As #1 
     Put #1, , CSVData 
    Close #1 

    rs.Close 
    Set rs = Nothing 

ExitPoint: 
    With Application 
     .ScreenUpdating = True 
     .DisplayAlerts = True 
    End With 
    Set rs = Nothing 
    Exit Sub 

ErrHandler: 
    MsgBox "An error occured - " & Err.Description, vbOKOnly 
    Resume ExitPoint 
End Sub 



Public Function RecordsetToCSV(rsData As ADODB.Recordset, _ 
     Optional ShowColumnNames As Boolean = True, _ 
     Optional NULLStr As String = "") As String 
    'Function returns a string to be saved as .CSV file 
    'Option: save column titles 

    Dim K As Long, RetStr As String 

    If ShowColumnNames Then 
     For K = 0 To rsData.Fields.Count - 1 
      RetStr = RetStr & ",""" & rsData.Fields(K).Name & """" 
     Next K 

     RetStr = Mid(RetStr, 2) & vbNewLine 
    End If 

    RetStr = RetStr & """" & rsData.GetString(adClipString, -1, """,""", """" & vbNewLine & """", NULLStr) 
    RetStr = Left(RetStr, Len(RetStr) - 3) 

    RecordsetToCSV = RetStr 
End Function 

Answer 1

Cela semble fonctionner sans restrictions de taille de fichier d'exportation en faisant 1k lignes à la fois et en utilisant FileSystemObject. Vous devez ajouter Microsoft ActiveX Data Objects Library et Microsoft Scripting Runtime en tant que références.

Option Explicit 

Public FSO As New FileSystemObject 

Public Sub ExportToCsv() 

    Dim wbTarget As Workbook 
    Dim ws As Worksheet 
    Dim rs As Object 
    Dim sQuery As String 

    'Suppress alerts and screen updates 
    With Application 
     .ScreenUpdating = False 
     .DisplayAlerts = False 
    End With 

    'Bind to active workbook 
    Set wbTarget = ActiveWorkbook 

    Err.Clear 

    On Error GoTo ErrHandler 

    'Make sure the model is loaded 
    wbTarget.Model.Initialize 

    'Send query to the model 
    sQuery = "EVALUATE <Query>" 
    Set rs = CreateObject("ADODB.Recordset") 
    rs.Open sQuery, wbTarget.Model.DataModelConnection.ModelConnection.ADOConnection 
    Dim CSVData As String 
    Call WriteRecordsetToCSV(rs, "<ExportPath>", True) 

    rs.Close 
    Set rs = Nothing 

ExitPoint: 
    With Application 
     .ScreenUpdating = True 
     .DisplayAlerts = True 
    End With 
    Set rs = Nothing 
    Exit Sub 

ErrHandler: 
    MsgBox "An error occured - " & Err.Description, vbOKOnly 
    Resume ExitPoint 
End Sub 



Public Sub WriteRecordsetToCSV(rsData As ADODB.Recordset, _ 
     FileName As String, _ 
     Optional ShowColumnNames As Boolean = True, _ 
     Optional NULLStr As String = "") 
    'Function returns a string to be saved as .CSV file 
    'Option: save column titles 

    Dim TxtStr As TextStream 
    Dim K As Long, CSVData As String 

    'Open file 
    Set TxtStr = FSO.CreateTextFile(FileName, True, True) 

    If ShowColumnNames Then 
     For K = 0 To rsData.Fields.Count - 1 
      CSVData = CSVData & ",""" & rsData.Fields(K).Name & """" 
     Next K 

     CSVData = Mid(CSVData, 2) & vbNewLine 
     TxtStr.Write CSVData 
    End If 

    Do While rsData.EOF = False 
     CSVData = """" & rsData.GetString(adClipString, 1000, """,""", """" & vbNewLine & """", NULLStr) 
     CSVData = Left(CSVData, Len(CSVData) - IIf(rsData.EOF, 3, 2)) 
     TxtStr.Write CSVData 
    Loop 

    TxtStr.Close 

End Sub