Option Explicit
Option Base 0
Sub csvCrossTabber()
'Create File
Dim CrossTabFile As String
Dim stTableName As String
Dim stColField As String
Dim stColList As String
Dim stRowList As String
Dim stRowList2 As String
Dim stValField As String
Dim stValList As String
Dim stWhere As String
Dim stWhere2 As String
Dim stAggFunction As String
' ***************************************** Change These Values As Needed *************************************
Const myFilePath = "C:\Documents and Settings\giacomo\My Documents\" ' don't forget to end with a slash \
Const OutputFileName = "AccCSV"
Const OutNum As Integer = 2
stTableName = "Table2" ' Name of table to query
stColField = "Day" ' Name of field to use as the column in crosstab
stValField = "Sales" ' Name of field to use as the value in crosstab
stAggFunction = "Sum" ' Aggregate function to perform on value field ( Example sum ,count, min, max )
Const numFields = 1 'This is the number of row fields in your crosstab starting at 0 (0 = 1, 1 = 2, etc.)
Dim arrRowFields(numFields) As String
arrRowFields(0) = "Region Name" ' Row Field 1
arrRowFields(1) = "Department" ' Row Field 2
' add more row fields as needed, increment the numFields too
' ******************************** Do not modify anything below this line ************************************
CrossTabFile = myFilePath & OutputFileName & ".csv"
'Kill Previous File if Exists
If FileExist(CrossTabFile) Then
Kill (CrossTabFile)
End If
'Open File
Open CrossTabFile For Append As OutNum
'Write Crosstab to File
'Connection Variables
Dim con As ADODB.Connection
Dim rs1 As ADODB.Recordset
Dim rs2 As ADODB.Recordset
Dim rs3 As ADODB.Recordset
Dim stSql1 As String
Dim stSql2 As String
Dim stSql3 As String
'Get First Row
Set con = Application.CurrentProject.Connection
stSql1 = "SELECT distinct [" & stColField & "] FROM [" & stTableName & "];"
Set rs1 = New ADODB.Recordset
rs1.Open stSql1, con, 1
Dim i As Integer
For i = 0 To numFields
stRowList = stRowList & arrRowFields(i) & ","
stRowList2 = stRowList2 & fieldBracket(arrRowFields(i)) & ","
Next i
If Not (rs1.EOF) Then
Do While (Not (rs1.EOF))
stColList = stColList & rs1(stColField) & ","
rs1.MoveNext
Loop
End If
stColList = Left(stColList, Len(stColList) - 1)
'Print out first row
Print #OutNum, stRowList; stColList
rs1.MoveFirst
'Write Values
stRowList2 = Left(stRowList2, Len(stRowList2) - 1)
stSql2 = "SELECT distinct " & stRowList2 & " FROM [" & stTableName & "];"
Set rs2 = New ADODB.Recordset
Set rs3 = New ADODB.Recordset
rs2.Open stSql2, con, 1
If Not (rs2.EOF) Then
Do While (Not (rs2.EOF))
stValList = ""
stWhere = ""
For i = 0 To numFields
stValList = stValList & rs2.Fields(i) & ","
stWhere = stWhere & fieldBracket(rs2.Fields(i).Name) & " = " & getDeliminator(rs2.Fields(i).Type) & rs2.Fields(i) & getDeliminator(rs2.Fields(i).Type) & " AND "
Next i
If Not (rs1.EOF) Then
Do While (Not (rs1.EOF))
stWhere2 = stWhere
stWhere2 = stWhere2 & fieldBracket(stColField) & " = " & getDeliminator(rs1(stColField).Type) & rs1(stColField) & getDeliminator(rs1(stColField).Type)
stSql3 = "SELECT " & stAggFunction & "([" & stValField & "]) FROM [" & stTableName & "] where " & stWhere2
rs3.Open stSql3, con, 1
If Not (rs3.EOF) Then
Do While (Not (rs3.EOF))
stValList = stValList & rs3.Fields(0) & ","
rs3.MoveNext
Loop
End If
rs1.MoveNext
rs3.Close
Loop
End If
Print #OutNum, Left(stValList, Len(stValList) - 1)
rs1.MoveFirst
rs2.MoveNext
Loop
End If
rs1.close
rs2.close
'Cleanup
Set rs1 = Nothing
Set con = Nothing
'Close File
Close #OutNum
End Sub
Function FileExist(myFileName$)
' First Check to ensure that myFileName is a valid file
On Error GoTo NotFound ' provide alternate error handling
Open myFileName$ For Input As 255 ' attempt to open file
On Error Resume Next ' if success, restore default error handling
Close 255 ' close file (it was only a test, afterall)
FileExist = True
Exit Function
NotFound:
On Error Resume Next
FileExist = False
End Function ' File Exist
Function fieldBracket(fieldName As String) As String
fieldBracket = fieldName
If InStr(1, fieldName, " ") > 0 Then
fieldBracket = "[" & fieldName & "]"
End If
End Function
Function getDeliminator(fieldType As Integer) As String
Select Case fieldType
Case 7
getDeliminator = "#"
Case 202
getDeliminator = "'"
Case Else
getDeliminator = ""
End Select
End Function
. In the procedure above your working with the data in the table as opposed to the query results. 
