Import Access Data into a series of Excel Files with DAO

Importer.vb

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