Importing from AS400 to CSV using Excel VBA - excel

Question

I am trying to export data from an AS400 table/file directly to a CSV File using Excel VBA. So far I have the following but it writes the output to the CSV file line by line and the headers do not seem to be included in the output.
I can output the data to Excel and save it as a CSV, but as it exceeds 1 million rows I only end up with half of what is required.
How to bulk dump the data into CSV and include the headers?
Sub ExportCSV()
Set Conn = CreateObject("adodb.connection")
Set rcd = CreateObject("adodb.recordset")
Set outFile = CreateObject("Scripting.FileSystemObject").CreateTextFile("H:\myFile.csv")
cnnstr = "DRIVER={Client Access ODBC Driver (32-bit)};SYSTEM=TEST;USERID=123;PWD=123"
Conn.Open cnnstr
Set rcd.ActiveConnection = Conn
sqlstm = "SELECT TEST50,LTEST50 FROM TESTLIB.TEST Where TEST50 Is Not NULL And LTEST50 Is Not NULL Order By TEST50 ASC "
rcd.Open sqlstm
rcd.MoveFirst
Do
outFile.WriteLine rcd("TEST50") & "," & rcd("LTEST50")
rcd.MoveNext
Loop Until rcd.EOF
rcd.Close
con.Close
Set rcd = Nothing
Set Conn = Nothing
End Sub

Answer 1

Here is a brute force approach, I am certain there are more elegant ways to load large text files in to Excel, such as the one that Chip Pearson put together:
http://www.cpearson.com/excel/ImportBigFiles.aspx
Otherwise, brute force approach could get you started:
Sub ExportCSV()
Dim wb as Object 'Excel.Workbook
Dim ws as Object 'Excel.Worksheet
Dim r As Long 'row counter/iterator
Set Conn = CreateObject("adodb.connection")
Set rcd = CreateObject("adodb.recordset")
Set outFile = CreateObject("Scripting.FileSystemObject").CreateTextFile("H:\myFile.csv")
cnnstr = "DRIVER={Client Access ODBC Driver (32-bit)};SYSTEM=TEST;USERID=123;PWD=123"
Conn.Open cnnstr
Set rcd.ActiveConnection = Conn
sqlstm = "SELECT TEST50,LTEST50 FROM TESTLIB.TEST Where TEST50 Is Not NULL And LTEST50 Is Not NULL Order By TEST50 ASC "
rcd.Open sqlstm
rcd.MoveFirst
'Create a new/empty Excel file
Set wb = CreateExcelFile()
Set ws = wb.Worksheets(1)
r = 1
'write the headers
Call WriteData(ws, r, "TEST50,LTEST50")
'Write the data
Do
If Not r > ws.Rows.Count Then
Call WriteData(ws, r, rcd("TEST50") & "," & rcd("LTEST50"))
Else
'begin with r=1 on a new worksheet
Set ws = wb.Worksheets.Add(After:=wb.Worksheets.Count)
r = 1
Call WriteData(ws, r, "TEST50,LTEST50")
End If
rcd.MoveNext
Loop Until rcd.EOF
End Sub
Sub WriteData(ws as Object, r as Long, strData as String)
With ws.Range("A" & r & ":B" & r)
.Value = Split(strData, ",")
End With
End Sub
Function CreateExcelFile() As Object
Dim xlApp as Object
Dim ret as Object
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then Set xlApp = CreateObject("Excel.Application")
On Error GoTo 0
Set ret = xlApp.Workbooks.Add
Do Until ret.Worksheets.Count = 1
ret.Worksheets(ret.Worksheets.Count).Delete
Loop
Set CreateExcelFile = ret
End Function