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
Dim colRows As New Collection
' ***************************************** Change These Values As Needed *************************************
Const myFilePath = "C:\giacomo\" ' don't forget to end with a slash \
Const OutputFileName = "AccCSV"
Const OutNum As Integer = 2
stTableName = "Order Summary" ' Name of table to query
stColField = "Customer ID" ' Name of field to use as the column in crosstab
stValField = "Sub Total" ' Name of field to use as the value in crosstab
stAggFunction = "Sum" ' Aggregate function to perform on value field ( Example sum ,count, min, max )
' add more row fields as needed
colRows.Add "Order Date"
' ******************************** Do not modify anything below this line ************************************
CrossTabFile = myFilePath & OutputFileName & ".csv"
'Kill Previous File if it 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 stSql1 As String
Dim stSql2 As String
Dim stSql3 As String
Dim i As Integer
For i = 1 To colRows.Count
stRowList = stRowList & colRows.Item(i) & ","
stRowList2 = stRowList2 & getWrapper(colRows.Item(i), True) & ","
Next i
'Get First Row
Set con = Application.CurrentProject.Connection
stSql1 = "SELECT distinct [" & stColField & "] FROM [" & stTableName & "];"
Set rs1 = New ADODB.Recordset
rs1.Open stSql1, con, 1
stColList = getRow(stSql1)
'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
rs2.Open stSql2, con, 1
If Not (rs2.EOF) Then
Do While (Not (rs2.EOF))
stValList = ""
stWhere = ""
For i = 0 To colRows.Count - 1
stValList = stValList & rs2.Fields(i) & ","
stWhere = stWhere & getWrapper(rs2.Fields(i).Name, True, rs2.Fields(i).Type) & " = " & getWrapper(rs2.Fields(i), False, rs2.Fields(i).Type) & " AND "
Next i
If Not (rs1.EOF) Then
Do While (Not (rs1.EOF))
stWhere2 = stWhere
stWhere2 = stWhere2 & getWrapper(stColField, True) & " = " & getWrapper(rs1(stColField), False, rs1(stColField).Type)
stSql3 = "SELECT " & stAggFunction & "([" & stValField & "]) FROM [" & stTableName & "] where " & stWhere2
stValList = stValList & getRow(stSql3)
rs1.MoveNext
Loop
End If
Print #OutNum, stValList
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 getWrapper(value As String, isField As Boolean, Optional fieldType As Integer) As String
getWrapper = value
If isField And InStr(1, value, " ") > 0 Then
getWrapper = "[" & value & "]"
End If
Select Case Nz(fieldType, 0)
Case 7
If isField Then
getWrapper = "cdbl(" & getWrapper & ")"
Else
getWrapper = "cdbl(#" & getWrapper & "#)"
End If
Case 202
getWrapper = "'" & getWrapper & "'"
Case Else
'Nothing
End Select
End Function
Function getRow(SQL As String) As String
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Set con = Application.CurrentProject.Connection
Set rs = New ADODB.Recordset
rs.Open SQL, con, 1
If Not (rs.EOF) Then
Do While (Not (rs.EOF))
getRow = getRow & rs.Fields(0) & ","
rs.MoveNext
Loop
End If
'getRow = Left(getRow, Len(getRow) - 1)
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
End Function
