Access VBA format export reports

Question

Access VBA format export reports

Anonymous

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

Thanks

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments

5 answers

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

Duane Hookom 26,825 Volunteer Moderator

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.

0 comments

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

Duane Hookom 26,825 Volunteer Moderator

"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?

0 comments

Share via

Access VBA format export reports

5 answers