Jonny wrote:
Hello,
I have created a button on my form which when pressed does the
following :
1) Run a pre-defined Macro, which is picking up a query and running my
data to excel.
However, I need the data to export into Excel in a certain format, i.e
it needs to begin importing at cell A4, and in truth it would be great
if I could get the data to populate a pre-designed excel worksheet.
would anyone be able to help me do this please ?
Thanks,
J.
This has just one problem in that you can only run it once and then you
have to restart Access before you can run it again (OK for weekly or
daily reports but not if you're exporting all day) due to some glitch
I've not been able to figure out yet.
It has all the formating bits in it you'll want and methods to use to
write Spreadhseets any way you want. it includes writing headers and
footers, set Window Zoom, settin gridlines and Row/Column headings on &
off formating cells and even adding comments to cells.
Hope this helps
Option Compare Database
Option Explicit
Function ExportTravelReport(strDestination As String) As Boolean
'On Error GoTo eh_ExportTravelReport
Dim dbLocal As Database
Dim rstTravel As Recordset
Dim intCurrTask As Integer
Dim wbknew As Excel.Workbook, wksnew As Excel.Worksheet
Dim appExcel As New Excel.Application
Dim strRange As String
Dim strCurrChannel As String
Dim strRecipients As String
Dim introw As Integer
Dim intStartRow As Integer
ExportTravelReport = True
'open data table
Set dbLocal = CurrentDb()
Set rstTravel = dbLocal.OpenRecordset("qry_Travel_Report_Output",
dbOpenSnapshot)
'set up Workbook
Set wbknew = appExcel.Workbooks.Add
Set wksnew = wbknew.Worksheets.Add
appExcel.Visible = True
'write Legend
wksnew.Cells(1, 7) = "Y = Qantas full economy"
wksnew.Cells(2, 7) = "B = Qantas 5 day advance purchase economy"
wksnew.Cells(3, 7) = "V = Qantas 14 day advance purchase economy"
wksnew.Cells(4, 7) = "H = Qantas 21 day advance purchase economy"
wksnew.Cells(5, 7) = "P = Qantas First Class"
wksnew.Cells(1, 10) = "M = Special domestic"
wksnew.Cells(2, 10) = "J = Business Class"
wksnew.Cells(3, 10) = "D = Discount Business Class"
wksnew.Cells(4, 10) = "F = First Class other"
Call SetColumnWidths
Call WriteComments
rstTravel.MoveFirst
introw = 5
Do While Not rstTravel.EOF
strCurrChannel = Nz(rstTravel!ChannelName, "unknown")
introw = WriteHeader(strCurrChannel, introw, wksnew)
intStartRow = introw
Do While rstTravel!ChannelName = strCurrChannel
'write record
wksnew.Cells(introw, 1) = rstTravel!BSB
wksnew.Cells(introw, 2) = rstTravel!CC
wksnew.Cells(introw, 3) = rstTravel!Type
wksnew.Cells(introw, 4) = rstTravel!Reference
wksnew.Cells(introw, 5) = rstTravel!Passenger
wksnew.Cells(introw, 6) = rstTravel!Value
wksnew.Cells(introw, 7) = rstTravel!CouponRouting
wksnew.Cells(introw, 8) = rstTravel!ClassUsed
wksnew.Cells(introw, 9) = rstTravel!AirlineUsed
wksnew.Cells(introw, 10) = CStr(Format(rstTravel!DDate,
"dd/mmm/yyyy"))
wksnew.Range(Cells(introw, 1), Cells(introw, 10)).Select
Call SetFont(False, False, 8)
Call SetInteriorBorder
Call SetEdgeLeftBorder
Call SetEdgeRightBorder
Call SetEdgeTopBorder
Call SetEdgeBottomBorder
wksnew.Cells(introw, 6).Select
Selection.NumberFormat = "$##,##0"
wksnew.Cells(introw, 10).Select
introw = introw + 1
rstTravel.MoveNext
If rstTravel.EOF Then Exit Do
Loop
Call WriteFooter(introw, wksnew, intStartRow)
introw = introw + 1
Loop
With ActiveWindow
.Zoom = 100
.DisplayGridlines = False
.DisplayHeadings = False
End With
wksnew.Range("G1:J5").Select
Selection.HorizontalAlignment = xlLeft
Call SetFont(True, False, 6)
If Dir(strDestination) = Right(strDestination, 22) Then
Kill strDestination
End If
Set wbknew = Nothing
Set wksnew = Nothing
ActiveWorkbook.SaveAs Filename:=strDestination, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False, CreateBackup:=False
If MsgBox("Do you want to sent this Travel Report now", vbYesNo,
"Send?") = vbYes Then
If appExcel.MailSystem <> xlNoMailSystem Then
strRecipients = InputBox("Enter the Email address for the
person receiving this Travel Report.", "Enter Recipient.")
If Not IsNull(Nz(strRecipients)) Then
appExcel.Dialogs(xlDialogSendMail).Show
arg1:=strRecipients, Arg2:="Travel Report for the month of " &
Forms!frm_Enter_Travel_Reports!cbo_Exp_Month
End If
Else
MsgBox "No Email system is available on this PC", , "No Email."
End If
End If
ActiveWorkbook.Close
appExcel.Quit
Set appExcel = Nothing
rstTravel.Close
dbLocal.Close
Exit Function
eh_ExportTravelReport:
ExportTravelReport = False
End Function
Sub SetFont(booBold As Boolean, booItal As Boolean, intSize As Integer,
Optional strFont As String)
With Selection.Font
.Bold = booBold
.Italic = booItal
.Name = IIf(IsMissing(strFont), "Arial", strFont)
.Size = intSize
End With
End Sub
Sub SetInteriorBorder()
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
Sub SetEdgeLeftBorder()
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
Sub SetEdgeRightBorder()
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
Sub SetEdgeTopBorder()
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
Sub SetEdgeBottomBorder()
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
Function WriteHeader(strChannel As String, introw As Integer, wksnew As
Worksheet) As Integer
'creates the header for each Channel
wksnew.Cells(introw, 1) = strChannel
wksnew.Cells(introw, 1).Select
Call SetFont(True, True, 10)
wksnew.Cells(introw, 1).Select
Selection.HorizontalAlignment = xlLeft
introw = introw + 1
'enter headings
wksnew.Cells(introw, 1) = "BSB"
wksnew.Cells(introw, 2) = "CC"
wksnew.Cells(introw, 3) = "Type"
wksnew.Cells(introw, 4) = "Invoice Reference"
wksnew.Cells(introw, 5) = "Passenger"
wksnew.Cells(introw, 6) = "Owing Value"
wksnew.Cells(introw, 7) = "Coupon Routing"
wksnew.Cells(introw, 8) = "Class Used"
wksnew.Cells(introw, 9) = "Airline Used"
wksnew.Cells(introw, 10) = "Depature Date"
'format headings
wksnew.Range(Cells(introw, 1), Cells(introw, 10)).Select
Call SetFont(True, False, 10)
Call SetEdgeLeftBorder
Call SetEdgeRightBorder
Call SetEdgeTopBorder
Call SetEdgeBottomBorder
WriteHeader = introw + 1
End Function
Sub WriteFooter(introw As Integer, wksnew As Worksheet, intStartRow As
Integer)
'writes and formats the subtotals for each Channel
introw = introw + 1
wksnew.Cells(introw, 5) = "Sub Total"
wksnew.Cells(introw, 5).Select
Call SetFont(True, False, 10)
wksnew.Cells(introw, 6).Value = "=Sum(F" & intStartRow & ":F" &
introw - 2 & ")"
wksnew.Cells(introw, 5).Select
Call SetFont(True, False, 10)
Selection.NumberFormat = "$##,##0"
End Sub
Sub SetColumnWidths()
Columns("A:A").ColumnWidth = 7.57
Columns("B:B").ColumnWidth = 4.29
Columns("C:C").ColumnWidth = 7.43
Columns("D:D").ColumnWidth = 18
Columns("E:E").ColumnWidth = 26.86
Columns("F:F").ColumnWidth = 12.71
Columns("G:G").ColumnWidth = 19.57
Columns("H:H").ColumnWidth = 10.86
Columns("I:I").ColumnWidth = 11.14
Columns("J:J").ColumnWidth = 18.57
Columns("A:J").Select
Selection.HorizontalAlignment = xlCenter
End Sub
Sub WriteComments()
Range("G6").Select
Range("G6").AddComment
Range("G6").Comment.Visible = False
Range("G6").Comment.Text Text:= _
"MEL = Melbourne" & Chr(10) & "SYD = Sydney" & Chr(10) & "CBR =
Canberra" & Chr(10) & "ADL = Adelaide"
Range("H6").Select
Range("H6").AddComment
Range("H6").Comment.Visible = False
Range("H6").Comment.Text Text:= _
"Y = Qantas full economy" & Chr(10) & "B = Qantas 5 day advance" &
Chr(10) & "V = Qantas 14 Day"
Range("H6").Comment.Shape.Height = 50
Range("H6").Comment.Shape.Width = 150
Range("I6").Select
Range("I6").AddComment
Range("I6").Comment.Visible = False
Range("I6").Comment.Text Text:= _
"QF = Qantas Airways" & Chr(10) & "UA = United Airlines" & Chr(10)
& "CO = Continental Airlines" & Chr(10) & "BA = British Airways"
Range("I6").Comment.Shape.Height = 50
Range("I6").Comment.Shape.Width = 150
End Sub
