Exporting powerpivot data to csv - vba

Question

I have an Excel workbook with powerpivot data in Excel data model. I don't have the file used to import the data into powerpivot. My goal is to get the data out of powerpivot to a csv so I can use it in some other software.
I can't find any direct export options in powerpivot and since the data is larger than 1.1M rows it can't be pushed into Excel.
I found this VBA which appears to work for smaller files but for larger ones I get a timeout error.
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

This seems to work without export file size restrictions by doing 1k rows at a time and using FileSystemObject. You'll need to add Microsoft ActiveX Data Objects Library and Microsoft Scripting Runtime as references.
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