Import Access Data into Excel (via VB and ADO)
I had a lot of data in MySql in a rails application, but I moved to Mongo on a new application and wanted to give the client a nice archive of excel files for each client. It has been a long time since I've worked with visual basic, but it came back quickly.
I was amazed how clunky the interface and I wrote some pretty redundant code, but this was my Saturday and I tried to get this out the door quickly. My basic workflow was to load an office trial version on a virtual machine, then install SQL server on windows and set up an ODBC connection string which I used to import all data into access. In access, I just wrote a bunch of sql strings and used access to automate excel via VBA.
Option Compare Database | |
Sub exportUser() | |
Dim intUser As Integer | |
Dim strUser As String | |
Dim oApp As Excel.Application | |
Dim wbk As Excel.Workbook | |
Dim wks As Excel.Worksheet | |
Dim rs As DAO.Recordset | |
Dim strSql As String | |
Dim i As Integer | |
strSql = "SELECT users.id, [first_name] & "" "" & [last_name] AS Name FROM users;" | |
Set rs = CurrentDb.OpenRecordset(strSql) | |
Set oApp = New Excel.Application | |
' ("c:\temp\" & strUser & ".xls") | |
oApp.Visible = True | |
If rs.RecordCount <> 0 Then | |
i = 0 | |
rs.MoveFirst | |
While Not rs.EOF | |
i = i + 1 | |
Set wbk = oApp.Workbooks.Add() | |
intUser = CInt(rs("id")) | |
strUser = CStr(rs("Name")) | |
display_exertions intUser, strUser, wbk | |
display_custom_workouts intUser, strUser, wbk | |
draw_measurements intUser, strUser, wbk | |
goals intUser, strUser, wbk | |
If FileOrDirExists("C:\temp\" & strUser & ".xls") Then | |
strFN = strUser & "_2" | |
Else | |
strFN = strUser | |
End If | |
wbk.SaveAs ("c:\temp\" & strFN & "_" & CStr(i) & ".xls") | |
wbk.Close | |
rs.MoveNext | |
Wend | |
End If | |
End Sub | |
Sub display_exertions(intUser, strUser, wbk) | |
Set wks = wbk.Worksheets.Add | |
wks.Name = "Workouts at Camps" | |
Dim rst As DAO.Recordset | |
Dim strSql As String | |
Dim i As Integer | |
strSql = "SELECT exercises.name, exertions.score, exertions.notes, exertions.user_note, exertions.rxd FROM exercises INNER JOIN (users INNER JOIN (meeting_users INNER JOIN exertions ON meeting_users.id = exertions.meeting_user_id) ON users.id = meeting_users.user_id) ON exercises.id = exertions.exercise_id WHERE (((users.id)=" & intUser & "));" | |
Set rst = CurrentDb.OpenRecordset(strSql) | |
wks.Cells(1, 1).Value = "name" | |
wks.Cells(1, 2).Value = "score" | |
wks.Cells(1, 3).Value = "notes" | |
wks.Cells(1, 4).Value = "user_note" | |
wks.Cells(1, 5).Value = "rxd" | |
i = 1 | |
If rst.RecordCount <> 0 Then | |
rst.MoveFirst | |
While Not rst.EOF | |
i = i + 1 | |
wks.Cells(i, 1).Value = rst(0) | |
wks.Cells(i, 2).Value = rst(1) | |
wks.Cells(i, 3).Value = rst(2) | |
wks.Cells(i, 4).Value = rst(3) | |
wks.Cells(i, 5).Value = rst(4) | |
Debug.Print rst("name"), rst("score"), rst("notes"), rst("user_note"), rst("rxd") | |
rst.MoveNext | |
Wend | |
End If | |
rst.Close | |
Set rst = Nothing | |
End Sub | |
Sub display_custom_workouts(intUser, strUser, wbk) | |
Set wks = wbk.Worksheets.Add | |
wks.Name = "Custom Workouts" | |
Dim rst As DAO.Recordset | |
Dim strSql As String | |
Dim i As Integer | |
strSql = "SELECT custom_workouts.custom_name, exercises.name, custom_workouts.workout_date, custom_workouts.pr, custom_workouts.description, custom_workouts.score FROM exercises INNER JOIN (users INNER JOIN custom_workouts ON users.id = custom_workouts.user_id) ON exercises.id = custom_workouts.exercise_id WHERE (((users.id)=" & intUser & "));" | |
Set rst = CurrentDb.OpenRecordset(strSql) | |
wks.Cells(1, 1).Value = "custom_name" | |
wks.Cells(1, 2).Value = "name" | |
wks.Cells(1, 3).Value = "workout_date" | |
wks.Cells(1, 4).Value = "pr" | |
wks.Cells(1, 5).Value = "description" | |
wks.Cells(1, 6).Value = "score" | |
If rst.RecordCount <> 0 Then | |
rst.MoveFirst | |
i = 1 | |
While Not rst.EOF | |
i = i + 1 | |
wks.Cells(i, 1).Value = rst("custom_name") | |
wks.Cells(i, 2).Value = rst("name") | |
wks.Cells(i, 3).Value = rst("workout_date") | |
wks.Cells(i, 4).Value = rst("pr") | |
wks.Cells(i, 5).Value = rst("description") | |
wks.Cells(i, 6).Value = rst("score") | |
rst.MoveNext | |
Wend | |
End If | |
rst.Close | |
Set rst = Nothing | |
End Sub | |
Sub draw_measurements(intUser, strUser, wbk) | |
Set wks = wbk.Worksheets.Add | |
wks.Name = "Measurements" | |
Dim rst As DAO.Recordset | |
Dim strSql As String | |
Dim i As Integer | |
strSql = "SELECT measurements.review_date, measurements.height, measurements.weight, measurements.chest, measurements.waist, measurements.hip, measurements.right_arm, measurements.right_thigh, measurements.bmi, measurements.bodyfat_percentage FROM users INNER JOIN measurements ON users.id = measurements.user_id WHERE (((users.id)=" & intUser & "));" | |
Set rst = CurrentDb.OpenRecordset(strSql) | |
wks.Cells(1, 1).Value = "review_date" | |
wks.Cells(1, 2).Value = "height" | |
wks.Cells(1, 3).Value = "weight" | |
wks.Cells(1, 4).Value = "chest" | |
wks.Cells(1, 5).Value = "waist" | |
wks.Cells(1, 6).Value = "hip" | |
wks.Cells(1, 7).Value = "right_arm" | |
wks.Cells(1, 8).Value = "right_thigh" | |
wks.Cells(1, 9).Value = "bmi" | |
wks.Cells(1, 10).Value = "bodyfat_percentage" | |
If rst.RecordCount <> 0 Then | |
rst.MoveFirst | |
i = 1 | |
While Not rst.EOF | |
i = i + 1 | |
wks.Cells(i, 1).Value = rst("review_date") | |
wks.Cells(i, 2).Value = rst("height") | |
wks.Cells(i, 3).Value = rst("weight") | |
wks.Cells(i, 4).Value = rst("chest") | |
wks.Cells(i, 5).Value = rst("waist") | |
wks.Cells(i, 6).Value = rst("hip") | |
wks.Cells(i, 7).Value = rst("right_arm") | |
wks.Cells(i, 8).Value = rst("right_thigh") | |
wks.Cells(i, 9).Value = rst("bmi") | |
wks.Cells(i, 10).Value = rst("bodyfat_percentage") | |
rst.MoveNext | |
Wend | |
End If | |
rst.Close | |
Set rst = Nothing | |
End Sub | |
Sub goals(intUser, strUser, wbk) | |
Set wks = wbk.Worksheets.Add | |
wks.Name = "Goals" | |
Dim rst As DAO.Recordset | |
Dim strSql As String | |
Dim i As Integer | |
strSql = "SELECT goals.goal_name, goals.description, goals.date_added, goals.target_date, goals.completed, goals.created_at, goals.updated_at, goals.completed_date FROM users INNER JOIN goals ON users.id = goals.user_id WHERE (((users.id)=" & intUser & "));" | |
Set rst = CurrentDb.OpenRecordset(strSql) | |
wks.Cells(1, 1).Value = "name" | |
wks.Cells(1, 2).Value = "description" | |
wks.Cells(1, 3).Value = "date added" | |
wks.Cells(1, 4).Value = "target date" | |
wks.Cells(1, 5).Value = "completed" | |
wks.Cells(1, 6).Value = "created at" | |
wks.Cells(1, 7).Value = "updated at" | |
wks.Cells(1, 8).Value = "date completed" | |
If rst.RecordCount <> 0 Then | |
rst.MoveFirst | |
i = 1 | |
While Not rst.EOF | |
i = i + 1 | |
wks.Cells(i, 1).Value = rst(0) | |
wks.Cells(i, 2).Value = rst(1) | |
wks.Cells(i, 3).Value = rst(2) | |
wks.Cells(i, 4).Value = rst(3) | |
wks.Cells(i, 5).Value = rst(4) | |
wks.Cells(i, 6).Value = rst(5) | |
wks.Cells(i, 7).Value = rst(6) | |
wks.Cells(i, 8).Value = rst(7) | |
rst.MoveNext | |
Wend | |
End If | |
rst.Close | |
Set rst = Nothing | |
End Sub | |
Function FileOrDirExists(PathName As String) As Boolean | |
'Macro Purpose: Function returns TRUE if the specified file | |
' or folder exists, false if not. | |
'PathName : Supports Windows mapped drives or UNC | |
' : Supports Macintosh paths | |
'File usage : Provide full file path and extension | |
'Folder usage : Provide full folder path | |
' Accepts with/without trailing "\" (Windows) | |
' Accepts with/without trailing ":" (Macintosh) | |
Dim iTemp As Integer | |
'Ignore errors to allow for error evaluation | |
On Error Resume Next | |
iTemp = GetAttr(PathName) | |
'Check if error exists and set response appropriately | |
Select Case Err.Number | |
Case Is = 0 | |
FileOrDirExists = True | |
Case Else | |
FileOrDirExists = False | |
End Select | |
'Resume error checking | |
On Error GoTo 0 | |
End Function |