Recently, I covered the case of converting CSV data into database table format.
Ex: A | B | C
ID | Business Name | Codes
72566477 | McDonald’s | Chicken_Sandwich,Fries,Diet_Coke,etc.
The below VBA code for MS Access provides for a way to reverse this process. That is, to convert the database table format:
Ex: A | B | C
ID | Business Name | Codes
72566477 | McDonald’s | Chicken_Sandwich
72566477 | McDonald’s | Fries
72566477 | McDonald’s | Diet_Coke
back to CSV like in the above example highlighted in green from the previous article (on a side note, please notice that the above table is not properly normalized and should be so for correct database structure). A better database design would take the following structure:
The function is currently setup without arguments but it can be easily modified for that. In it’s current setup, it’s easy to understand how to use the function and adjust it for your dataset but it would be limited to one-time use, i.e. it will need to be modified for arguments to be used in a looping algorithm.
Download: MakeCSV
Public Sub MakeCSV()
On Error GoTo ErrHandler
Dim con As ADODB.Connection
Dim rst As New ADODB.Recordset
Dim rst1 As New ADODB.Recordset
Dim cat As New ADOX.Catalog
Dim fld As ADODB.Field
Dim tbl As ADOX.Table
Set con = Application.CurrentProject.Connection
Set cat.ActiveConnection = con
Dim strSQL As String, CSVKey() As String, CSVValueList As String
Dim CSVField() As String, CSVSource As String, MasterSource As String, NewTable As String
Dim NumberOfFields As Long, x As Long, y As Long, NumberGroupFields As Long
Dim LongData As Boolean, OnlyUnique As Boolean
'Set the name for the table you want to create
NewTable = "NEW_TABLE_NAME"
'Are you dealing with long data (>255 characters) or short data?
LongData = False
'Set the name of the table or query to reference
MasterSource = "EXISTING_QUERY_OR_TABLE_NAME"
'Set the number of grouping fields
NumberGroupFields = 3
'Allocate the array - //////// DO NOT ALTER THIS LINE \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
ReDim CSVKey(NumberGroupFields, 1)
'Set the Name of the key field you want to reference the CSV
CSVKey(1, 0) = "GROUP_FIELD_NAME_1"
CSVKey(2, 0) = "GROUP_FIELD_NAME_2"
CSVKey(3, 0) = "GROUP_FIELD_NAME_3"
'Set the number of fields you want to turn into a CSV
NumberOfFields = 2
'Allocate the array - //////// DO NOT ALTER THIS LINE \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
ReDim CSVField(NumberOfFields)
'Set the name of the field or fields you want to turn into CSV
CSVField(1) = "CSV_FIELD_NAME_1"
CSVField(2) = "CSV_FIELD_NAME_2"
'CSVField(3) = "CSV_FIELD_NAME_3"
'Grab Only Unique Values for the CSV?
OnlyUnique = True
'/////////////////////// DO NOT ALTER THE LINES BELOW \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'Check to see if the table exists - if it does, drop it
For Each tbl In cat.Tables
If tbl.Name = NewTable Then
cat.Tables.Delete NewTable
End If
Next tbl
'Determine the data types for the CSVKey values
strSQL = "SELECT TOP 1"
For y = 1 To NumberGroupFields
strSQL = strSQL & " [" & CSVKey(y, 0) & "],"
Next y
strSQL = Left(strSQL, Len(strSQL) - 1)
strSQL = strSQL & " FROM [" & MasterSource & "]"
With rst
.Open strSQL, con, adOpenStatic, adLockReadOnly
y = 1
For Each fld In rst.Fields
If fld.Type = 7 Then
CSVKey(y, 1) = "Date"
ElseIf fld.Type = 202 Then
CSVKey(y, 1) = "Text"
ElseIf fld.Type = adBigInt Then
CSVKey(y, 1) = "Numeric"
End If
y = y + 1
Next fld
.Close
End With
'Create a table to hold the CSV values
strSQL = "CREATE TABLE [" & NewTable & "]"
strSQL = strSQL & " ([" & CSVKey(1, 0) & "] TEXT(255),"
If NumberGroupFields >= 2 Then
For y = 2 To NumberGroupFields
strSQL = strSQL & " [" & CSVKey(y, 0) & "] TEXT(255),"
Next y
End If
For x = 1 To NumberOfFields
If LongData = True Then
strSQL = strSQL & " [" & CSVField(x) & "] MEMO,"
Else
strSQL = strSQL & " [" & CSVField(x) & "] TEXT(255),"
End If
Next x
strSQL = Left(strSQL, Len(strSQL) - 1)
strSQL = strSQL & ")"
'Create the table
con.Execute strSQL
'Get the unique source items
For x = 1 To NumberOfFields
'Get the distinct CSVKeys
strSQL = "SELECT DISTINCT"
For y = 1 To NumberGroupFields
strSQL = strSQL & " [" & CSVKey(y, 0) & "],"
Next y
strSQL = Left(strSQL, Len(strSQL) - 1)
strSQL = strSQL & " FROM [" & MasterSource & "]"
With rst
.Open strSQL, con, adOpenStatic, adLockReadOnly
.MoveFirst
While Not .EOF
'Retrieve the values for the CSV list
If OnlyUnique = False Then
strSQL = "SELECT [" & CSVField(x) & "] FROM [" & MasterSource & "]"
Else
strSQL = "SELECT DISTINCT [" & CSVField(x) & "] FROM [" & MasterSource & "]"
End If
For y = 1 To NumberGroupFields
If y = 1 Then
If CSVKey(1, 1) = "Text" Then
strSQL = strSQL & " WHERE ((([" & CSVKey(1, 0) & "]) = " & Chr(34) & rst.Fields(CSVKey(1, 0)) & Chr(34) & ")"
ElseIf CSVKey(1, 1) = "Numeric" Then
strSQL = strSQL & " WHERE ((([" & CSVKey(1, 0) & "]) = " & rst.Fields(CSVKey(1, 0)) & ")"
ElseIf CSVKey(1, 1) = "Date" Then
strSQL = strSQL & " WHERE ((([" & CSVKey(1, 0) & "]) = #" & rst.Fields(CSVKey(1, 0)) & "#)"
End If
Else
If CSVKey(y, 1) = "Text" Then
strSQL = strSQL & " AND (([" & CSVKey(y, 0) & "]) = " & Chr(34) & rst.Fields(CSVKey(y, 0)) & Chr(34) & ")"
ElseIf CSVKey(y, 1) = "Numeric" Then
strSQL = strSQL & " AND (([" & CSVKey(y, 0) & "]) = " & rst.Fields(CSVKey(y, 0)) & ")"
ElseIf CSVKey(y, 1) = "Date" Then
strSQL = strSQL & " AND (([" & CSVKey(y, 0) & "]) = #" & rst.Fields(CSVKey(y, 0)) & "#)"
End If
End If
Next y
strSQL = strSQL & ")"
With rst1
.Open strSQL, con, adOpenStatic, adLockReadOnly
.MoveFirst
'Create the CSV list
While Not .EOF
CSVValueList = CSVValueList & .Fields(CSVField(x)) & ", "
.MoveNext
Wend
CSVValueList = Left(CSVValueList, Len(CSVValueList) - 2)
.Close
End With
'Now insert the CSV values
strSQL = "SELECT [" & CSVField(x) & "],"
For y = 1 To NumberGroupFields
strSQL = strSQL & " [" & CSVKey(y, 0) & "],"
Next y
strSQL = Left(strSQL, Len(strSQL) - 1)
strSQL = strSQL & " FROM [" & NewTable & "]"
strSQL = strSQL & " WHERE ((([" & CSVKey(1, 0) & "]) = " & Chr(34) & rst.Fields(CSVKey(1, 0)) & Chr(34) & ")"
If NumberGroupFields >= 2 Then
For y = 2 To NumberGroupFields
strSQL = strSQL & " AND (([" & CSVKey(y, 0) & "]) = " & Chr(34) & rst.Fields(CSVKey(y, 0)) & Chr(34) & ")"
Next y
strSQL = strSQL & ")"
Else
strSQL = strSQL & ")"
End If
With rst1
.Open strSQL, con, adOpenDynamic, adLockOptimistic
If .BOF = True And .EOF = True Then
'Add a new record
.AddNew CSVKey(1, 0), rst.Fields(CSVKey(1, 0))
For y = 2 To NumberGroupFields
.Update CSVKey(y, 0), rst.Fields(CSVKey(y, 0))
Next y
.Update CSVField(x), CSVValueList
Else
'Record Exists
.Update CSVField(x), CSVValueList
End If
.Close
End With
'Clear the CSV value
CSVValueList = ""
'Move to the next CSVKey
.MoveNext
Wend
.Close
End With
Next x
'Close the connections
con.Close
Set rst = Nothing
Set rst1 = Nothing
Set cat = Nothing
Set tbl = Nothing
Set fld = Nothing
Set con = Nothing
Exit Sub
ErrHandler:
'Close the connections
MsgBox "MakeCSV encountered error " & Err.Number & " : " & Err.Description, vbCritical + vbOKOnly, "MakeCSV Encountered Error " & Err.Number
If rst.State = adStateOpen Then
rst.Close
End If
If rst1.State = adStateOpen Then
rst1.Close
End If
con.Close
Set rst = Nothing
Set rst1 = Nothing
Set cat = Nothing
Set tbl = Nothing
Set fld = Nothing
Set con = Nothing
Exit Sub
End Sub
Filed under: Programming, Technology | Leave a comment »
The Voice of Reason 