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

view raw
Importer.vb
hosted with ❤ by GitHub

Leave a Reply

This site uses Akismet to reduce spam. Learn how your comment data is processed.