Access VBA format export reports

Question

I am attempting to export a schedule report to excel with specific formatting and layout but having trouble setting the formatting. below is the export code.

'------------------------------------------------------------

' Macro1

'

'------------------------------------------------------------

Function Macro1()

On Error GoTo Macro1_Err

    DoCmd.OutputTo acOutputReport, "rptTrainingSchedule", "Excel97-Excel2003Workbook(*.xls)", "Training Level III.xls", True, "", , acExportQualityPrint

DoCmd.Hourglass False

Macro1_Exit:

    Exit Function

Macro1_Err:

    MsgBox Error$

    Resume Macro1_Exit

End Function

Below is the specific formatting I would like to achieve however I cant seem to make it work.

With excelApp

    .Sheets("Sheet1").Select

    .Sheets("Sheet1").name = "Level III Gantt Chart"

End With

'Set column widths

With excelApp.Sheets("Level III Gantt Chart")

    .Columns("A").EntireColumn.ColumnWidth = 13.57

    .Columns("B").EntireColumn.ColumnWidth = 45

    .Columns("C").EntireColumn.ColumnWidth = 8.43

    .Columns("D").EntireColumn.ColumnWidth = 8.43

    .Columns("E:O").EntireColumn.ColumnWidth = 4

    .Rows(1).EntireRow.RowHeight = 31.5

End With

'Create header

With excelApp.Sheets("Level III Gantt Chart")

    .Range("A1:O1").Merge

    .Range("A1:O1").Borders(xlEdgeRight).Weight = xlMedium

    With .Range("A1")

        .Value = " LEVEL III"

        .Font.FontStyle = "Bold"

        .Font.Size = 13

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

    End With

    With .Range("A2:O3")

        .Borders(xlEdgeRight).Weight = xlMedium

        .Borders(xlEdgeLeft).Weight = xlMedium

        .Borders(xlEdgeTop).Weight = xlMedium

        .Borders(xlEdgeBottom).Weight = xlMedium

        .Borders(xlInsideHorizontal).Weight = xlThin

        .Borders(xlInsideVertical).Weight = xlThin

    End With

'Project Number

    .Range("A2:B2").Merge

    .Range("A2").Value = ""

    .Range("C2:G2").Merge

    .Range("C2").Value = ""

'Date Generated

    .Range("H2:L2").Merge

    .Range("H2").Value = "Date Generated:"

    .Range("G2").Value = ""

    .Range("M2:O2").Merge

    .Range("M2").Value = Date

'Project Title

    .Range("A3:B3").Merge

    .Range("A3").Value = ""

    .Range("C3:G3").Merge

    .Range("C3").Value = ""

'Time generated

    .Range("H3:L3").Merge

    .Range("H3").Value = "Time Generated:"

    .Range("M3:O3").Merge

    .Range("M3").Value = Time

'Column Headers for MA section

    .Range("A4").Value = "CIN."

    .Range("B4").Value = "Course Title"

    .Range("C4").Value = "Min"

    .Range("D4").Value = "Max"

    With .Range("A4:D4")

        .Font.FontStyle = "Bold"

        .VerticalAlignment = xlCenter

    End With

    .Range("A4:A6").Merge

    .Range("B4:B6").Merge

    .Range("C4:C6").Merge

    .Range("D4:D6").Merge

    With .Range("A4")

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

        .WrapText = True

    End With

    With .Range("B4")

        .HorizontalAlignment = xlLeft

        .VerticalAlignment = xlCenter

        .WrapText = True

    End With

    With .Range("C4")

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

        .WrapText = True

    End With

    With .Range("D4")

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

        .WrapText = True

    End With

    With .Range("A4:D6")

        .Borders(xlEdgeRight).Weight = xlMedium

        .Borders(xlInsideVertical).Weight = xlMedium

    End With

End With

Thanks

Answer 1

If your Access question has been answered, you'll probably get better help in an Excel forum. Also, I'd suggest you make the Excel file available for download (with any sensitive data removed, of course). Posting hundreds of lines of code is usually not a good idea, since we don't really have the time to trace through that code to determine your issue.

Answer 2

Thanks again for your reply, I have since solved my initial problem. having said that I have encountered a new one and I don't know if you can help with out the db. but I will post the code in hopes you can.

new problem:

when the code runs its intended to copy all records to an excel then towards the end its paints in fields for dates, however it is painting in dates based off the first occurrence of an activity. what I need to figure out is how to make it recognize the second set of dates.

below is current coding:

Private Sub Level_III_Click()

'DECLARATIONS

Dim excelApp As Excel.Application

Dim workbooks As Excel.Workbook

Dim sheets As Excel.worksheets

Dim range As Excel.range

Dim db As Database

Dim sql As String

Dim rstraining_booking_ref_cert_and_quals As DAO.Recordset

Dim rstraining_booking_junction_coure_offerings As DAO.Recordset

Dim admin As DAO.Recordset

Dim rsCINinfo As DAO.Recordset

Dim rsInClass As DAO.Recordset

Dim SQLrsInClass As String

Dim rsDayCrew As DAO.Recordset

Dim SQLDayCrew As String

Dim columncount, i, cacount, InClass As Long

Dim recordcount As Integer

Dim start_date As Date

Dim end_date As Date

Dim caStart As Date

Dim CAend As Date

'CREATE NEW EXCEL

Set excelApp = New Excel.Application

    excelApp.workbooks.add

    excelApp.DisplayAlerts = True

    excelApp.ScreenUpdating = True

With excelApp

    .sheets(1).Select

    .sheets(1).NAME = ("Gantt")

End With

'COLUMN WIDTH

With excelApp.sheets("Gantt")

    .Columns("A").EntireColumn.ColumnWidth = 13.57

    .Columns("B").EntireColumn.ColumnWidth = 45

    .Columns("C").EntireColumn.ColumnWidth = 8.43

    .Columns("D").EntireColumn.ColumnWidth = 8.43

    .Columns("E:O").EntireColumn.ColumnWidth = 4

End With

'TITLE BLOCK

With excelApp.sheets("Gantt")

    .range("A1:O1").Merge

    .range("A1:O1").Borders(xlEdgeRight).Weight = xlMedium

End With

With excelApp.sheets("Gantt")

    .range("A1") = "Level III"

    .range("A1").Font.FontStyle = "Bold"

    .range("A1").Font.Size = 13

    .range("A1").HorizontalAlignment = xlCenter

    .range("A1").VerticalAlignment = xlCenter

End With

With excelApp.sheets("Gantt")

    .range("A4").value = "CIN"

    .range("B4").value = "Course Title"

    .range("C4").value = "Min"

    .range("D4").value = "Max"

End With

'HEADER INFO

With excelApp.sheets("Gantt")

    .range("A4").Font.FontStyle = "Bold"

    .range("A4").VerticalAlignment = xlCenter

End With

With excelApp.sheets("Gantt")

    .range("B4").Font.FontStyle = "Bold"

    .range("B4").VerticalAlignment = xlCenter

End With

With excelApp.sheets("Gantt")

    .range("C4").Font.FontStyle = "Bold"

    .range("C4").VerticalAlignment = xlCenter

End With

With excelApp.sheets("Gantt")

    .range("D4").Font.FontStyle = "Bold"

    .range("D4").VerticalAlignment = xlCenter

End With

With excelApp.sheets("Gantt")

    .range("A4:D4").HorizontalAlignment = xlCenter

    .range("A4:D4").VerticalAlignment = xlCenter

    .range("A4:D4").WrapText = True

    .range("A4:D4").Borders(xlEdgeRight).Weight = xlMedium

    .range("A4:D4").Borders(xlInsideVertical).Weight = xlMedium

End With

With excelApp.sheets("Gantt")

    .range("A4:A6").Merge

    .range("B4:B6").Merge

    .range("C4:C6").Merge

    .range("D4:D6").Merge

End With

'Open recordset with CAs ordered by baseline early start and then CA number

sql = "SELECT distinctrow cq.CIN, cq.course_name, to.min_number_of_seats, to.number_of_seats, to.start_date, to.end_date from training_booking_ref_certs_and_quals cq inner join training_booking_junction_coure_offerings to on cq.cert_id = to.cert_id order by to.start_date asc, to.end_date asc;"

Set rsCINinfo = CurrentDb.openrecordset(sql)

cacount = rsCINinfo.recordcount

'Transfer CAs from recordset

excelApp.sheets("Gantt").range("A7:D" & 2 + (5 * cacount)).CopyFromRecordset rsCINinfo, , 4

'INFO INSERT

 For i = 0 To cacount

    excelApp.sheets("Gantt").Rows(8 + cacount - i & ":" & 11 + cacount - i).Insert Shift:=xlShiftDown

Next i

'Cell formatting

For i = 1 To cacount

    With excelApp.sheets("Gantt")

        .range("A" & 2 + (5 * i) & ":A" & 6 + (5 * i)).Merge

        .range("B" & 2 + (5 * i) & ":B" & 6 + (5 * i)).Merge

        .range("C" & 2 + (5 * i) & ":C" & 6 + (5 * i)).Merge

        .range("D" & 2 + (5 * i) & ":D" & 6 + (5 * i)).Merge

        .Rows(2 + (5 * i)).RowHeight = 4.5

        .Rows(3 + (5 * i)).RowHeight = 4.5

        .Rows(5 + (5 * i)).RowHeight = 4.5

        .Rows(6 + (5 * i)).RowHeight = 4.5

    End With

Next i

With excelApp.sheets("Gantt")

    With .range("A7:D" & 6 + (5 * cacount))

        .Borders(xlEdgeTop).Weight = xlMedium

        .Borders(xlEdgeRight).Weight = xlMedium

        .Borders(xlEdgeBottom).Weight = xlMedium

        .Borders(xlInsideHorizontal).Weight = xlMedium

        .Borders(xlInsideVertical).Weight = xlMedium

        .VerticalAlignment = xlCenter

    End With

    .range("A7:A" & 6 + (5 * cacount)).HorizontalAlignment = xlCenter

    .range("B7:B" & 6 + (5 * cacount)).HorizontalAlignment = xlLeft

    .range("B7:B" & 6 + (5 * cacount)).WrapText = True

    .range("C7:C" & 6 + (5 * cacount)).HorizontalAlignment = xlCenter

    .range("D7:D" & 6 + (5 * cacount)).HorizontalAlignment = xlCenter

End With

'Add calendar bar to Gantt chart area

columncount = Me.end_date - Me.start_date + 1

For i = 1 To columncount

    With excelApp.sheets("Gantt").Cells(5, 4 + i)

        .value = Me.start_date + i - 1

        .NumberFormat = "dd;@"

        .Font.FontStyle = "Bold"

        .HorizontalAlignment = xlCenter

    End With

    With excelApp.sheets("Gantt").Cells(6, 4 + i)

        .value = WeekdayName(Weekday(excelApp.sheets("Gantt").Cells(5, 4 + i).value, vbSunday), True, vbSunday)

        .Font.FontStyle = "Bold"

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

    End With

    'Merge cells with same month name

    If IsDate(excelApp.sheets("Gantt").Cells(5, 3 + i).value) And IsDate(excelApp.sheets("Gantt").Cells(5, 4 + i).value) _

        And Month(excelApp.sheets("Gantt").Cells(5, 3 + i).value) = Month(excelApp.sheets("Gantt").Cells(5, 4 + i).value) Then

            excelApp.sheets("Gantt").range(excelApp.Cells(4, 3 + i), excelApp.Cells(4, 4 + i)).Merge

            excelApp.sheets("Gantt").range(excelApp.Cells(9 + (5 * cacount), 3 + i), excelApp.Cells(9 + (5 * cacount), 4 + i)).Merge

    End If

    With excelApp.sheets("Gantt").Cells(4, 4 + i)

        .value = MonthName(Month(excelApp.sheets("Gantt").Cells(5, 4 + i).value), False)

        .Font.FontStyle = "Bold"

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

    End With

    'mirror on bottom

    With excelApp.sheets("Gantt").Cells(8 + (5 * cacount), 4 + i)

        .value = Me.start_date + i - 1

        .NumberFormat = "dd;@"

        .Font.FontStyle = "Bold"

        .HorizontalAlignment = xlCenter

    End With

    With excelApp.sheets("Gantt").Cells(7 + (5 * cacount), 4 + i)

        .value = WeekdayName(Weekday(excelApp.sheets("Gantt").Cells(5, 4 + i).value, vbSunday), True, vbSunday)

        .Font.FontStyle = "Bold"

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

    End With

    With excelApp.sheets("Gantt").Cells(9 + (5 * cacount), 4 + i)

        .value = MonthName(Month(excelApp.sheets("Gantt").Cells(5, 4 + i).value), False)

        .Font.FontStyle = "Bold"

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

    End With

    'NCF-778: widen columns to fit percentages in WIP

    excelApp.sheets("Gantt").Columns(4 + i).EntireColumn.ColumnWidth = 4.71

Next i

'NCF-778: set column widths for 2 columns past end of report

excelApp.sheets("Gantt").Columns(5 + columncount).EntireColumn.ColumnWidth = 4.71

excelApp.sheets("Gantt").Columns(6 + columncount).EntireColumn.ColumnWidth = 4.71

With excelApp.sheets("Gantt").range(excelApp.sheets("Gantt").Cells(4, 5), excelApp.sheets("Gantt").Cells(6, 4 + columncount))

    .Borders(xlEdgeTop).Weight = xlMedium

    .Borders(xlEdgeRight).Weight = xlMedium

    .Borders(xlEdgeBottom).Weight = xlMedium

    .Borders(xlInsideHorizontal).Weight = xlMedium

    .Borders(xlInsideVertical).Weight = xlMedium

End With

With excelApp.sheets("Gantt").range(excelApp.sheets("Gantt").Cells(7 + (5 * cacount), 5), excelApp.sheets("Gantt").Cells(9 + (5 * cacount), 4 + columncount))

    .Borders(xlEdgeLeft).Weight = xlMedium

    .Borders(xlEdgeTop).Weight = xlMedium

    .Borders(xlEdgeRight).Weight = xlMedium

    .Borders(xlEdgeBottom).Weight = xlMedium

    .Borders(xlInsideHorizontal).Weight = xlMedium

    .Borders(xlInsideVertical).Weight = xlMedium

End With

For i = 1 To cacount

    'format cells in Gantt chart area

    With excelApp.sheets("Gantt").range(excelApp.sheets("Gantt").Cells(2 + (5 * i), 5), excelApp.sheets("Gantt").Cells(6 + (5 * i), 4 + columncount))

        .Borders(xlEdgeRight).Weight = xlMedium

        .Borders(xlEdgeBottom).Weight = xlMedium

    End With

    rsCINinfo.FindFirst ("CIN = '" & excelApp.sheets("Gantt").Cells(2 + (5 * i), 1).value & "'")

    If rsCINinfo!start_date < Me.start_date Then

        caStart = Me.start_date

    Else

        caStart = rsCINinfo!start_date

    End If

    If rsCINinfo!end_date > Me.end_date Then

        CAend = Me.end_date

    Else

        CAend = rsCINinfo!end_date

    End If

    If caStart <= Me.end_date And CAend >= Me.start_date Then

    With excelApp.sheets("Gantt")

        .range(excelApp.sheets("Gantt").Cells(3 + (5 * i), 5 + rsCINinfo!start_date - Me.start_date), excelApp.sheets("Gantt").Cells(3 + (5 * i), 5 + rsCINinfo!end_date - Me.start_date)).Interior.Color = RGB(255, 0, 0)

        .range(excelApp.sheets("Gantt").Cells(5 + (5 * i), 5 + rsCINinfo!start_date - Me.start_date), excelApp.sheets("Gantt").Cells(5 + (5 * i), 5 + rsCINinfo!end_date - Me.start_date)).Interior.Color = RGB(255, 0, 0)

    End With

    With excelApp.sheets("Gantt").range(excelApp.sheets("Gantt").Cells(4 + (5 * i), 5 + rsCINinfo!start_date - Me.start_date), excelApp.sheets("Gantt").Cells(4 + (5 * i), 5 + rsCINinfo!end_date

• Me.start_date))

            .Borders(xlEdgeTop).LineStyle = xlSolid

            .Borders(xlEdgeTop).Weight = xlMedium

            .Borders(xlEdgeBottom).LineStyle = xlSolid

            .Borders(xlEdgeBottom).Weight = xlMedium

            .Borders(xlEdgeRight).LineStyle = xlSolid

            .Borders(xlEdgeRight).Weight = xlMedium

            .Borders(xlEdgeLeft).LineStyle = xlSolid

            .Borders(xlEdgeLeft).Weight = xlMedium

    End With

End If

Next i

rsCINinfo.Close

'Get crew type descriptions for bottom section

SQLrsInClass = "SELECT distinct ad.RANK from admin ad inner join training_booking_junction_courses_taking ct on ad.troop_id = ct.troop_id order by ad.RANK asc;"

Set rsInClass = CurrentDb.openrecordset(SQLrsInClass)

InClass = rsInClass.recordcount

'count crew by rate for each day on the report

If Not rsInClass.EOF Then rsInClass.MoveFirst

Do Until rsInClass.EOF

    With excelApp.sheets("Gantt")

        .range("B" & 10 + (5 * cacount) + rsInClass.AbsolutePosition).value = rsInClass!RANK

        .range("C" & 10 + (5 * cacount) + rsInClass.AbsolutePosition & ":D" & 10 + (5 * cacount) + rsInClass.AbsolutePosition).Merge

        For i = 1 To columncount

            SQLDayCrew = "SELECT distinct to.course_id from((training_booking_junction_coure_offerings as to inner join training_booking_junction_courses_taking as ct on to.course_id = ct.course_id) inner join admin ad on ad.troop_id = ct.troop_id) WHERE to.start_date <= #" & Me.start_date - 1 + i & "# and to.end_date >= #" & Me.start_date - 1 + i & "# and ad.RANK = '" & rsInClass!RANK & "';"

            Set rsDayCrew = CurrentDb.openrecordset(SQLDayCrew)

            If rsDayCrew.recordcount > 0 Then excelApp.sheets("Gantt").Cells(10 + (5 * cacount) + rsInClass.AbsolutePosition, 4 + i).value = rsDayCrew.recordcount

        Next i

    End With

    rsInClass.moveNext

Loop

With excelApp.sheets("Gantt").range("B" & 10 + (5 * cacount) + rsInClass.recordcount)

    .value = "Total in Class"

    .HorizontalAlignment = xlRight

End With

excelApp.sheets("Gantt").range("C" & 10 + (5 * cacount) + rsInClass.recordcount & ":D" & 10 + (5 * cacount) + rsInClass.recordcount).Merge

For i = 1 To columncount

    excelApp.sheets("Gantt").Cells(10 + (5 * cacount) + rsInClass.recordcount, 4 + i).FormulaR1C1 = "=SUM(R[-" & rsInClass.recordcount & "]C:R[-1]C)"

Next i

With excelApp.sheets("Gantt").range(excelApp.sheets("Gantt").Cells(10 + (5 * cacount), 2), excelApp.sheets("Gantt").Cells(10 + (5 * cacount) + rsInClass.recordcount, 4 + columncount))

    .Borders(xlEdgeTop).Weight = xlMedium

    .Borders(xlEdgeLeft).Weight = xlMedium

    .Borders(xlEdgeBottom).Weight = xlMedium

    .Borders(xlEdgeRight).Weight = xlMedium

    .Borders(xlInsideVertical).Weight = xlThin

    .Borders(xlInsideHorizontal).Weight = xlThin

End With

excelApp.sheets("Gantt").range(excelApp.sheets("Gantt").Cells(2, 1), excelApp.sheets("Gantt").Cells(10 + (5 * cacount) + rsInClass.recordcount, 4 + columncount)).Font.Size = 10

excelApp.sheets("Gantt").range("A1").Select

excelApp.Visible = True

excelApp.ScreenUpdating = True

End Sub

Answer 3

Without having a copy of your database I doubt anyone can see what you are seeing for results. You provide about 100  lines of code and we have no idea what happens and how it is not meeting your requirements.

Answer 4

dhookom,

Thanks for your response. basically I would like to export a report with class information (course #, course title, Min/Max seats available, start and end dates) and have it auto populate into a calendar like format.

my intent is to have course #/ course name/ min/ max followed by date ranges that auto fill based off start and end dates, with the min and max totals across the bottom.

below is a very crude representation of how I would like it to look.

_______________________________ | Pick a month

CIN | Course Title | Min | Max | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | ....

123 | Name          | 5      | 10    |----|----|

                                                | 5   | 5   |

                                                | 10 | 10 |

Answer 5

"I cant seem to make it work" doesn't provide anything for us to work with. Can you provide more details about what does and doesn't happen?