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 |
