By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
424,853 Members | 995 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 424,853 IT Pros & Developers. It's quick & easy.

Export Data to Excel

P: n/a
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.
Nov 13 '05 #1
Share this Question
Share on Google+
5 Replies


P: n/a
Export your data into a standard worksheet and in your pre-designed excel
worksheet use formulas to get the data from that worksheet.

--
PC Datasheet
Your Resource For Help With Access, Excel And Word Applications
re******@pcdatasheet.com
www.pcdatasheet.com
"Jonny" <jo**********@yahoo.com> wrote in message
news:14**************************@posting.google.c om...
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.

Nov 13 '05 #2

P: n/a
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
Nov 13 '05 #3

P: n/a
I am having a similar problem. I have HUGE database, millions of
records, I need a large sum of them in Excel. Because one spreadsheet
in excel can only hold 65,536 rows of data I am forced to use multiple
spreadsheets. I have written a macro in access to select which ever
65,536 rows of data in need. I thought that would be the hard part...I
was wrong. Now I need this macro (in access) to copy the selected
rows, then I could use a macro in excel to paste them. If you could
help me past this problem, I will try my best to help you.
Nov 13 '05 #4

P: n/a
Hi,

Your programming problem is in the Excel universe. I'd post in relevant
Excel newsgroups so solve the problem you posted. Once you can do it in
Excel using VBA you can then copy the code into Access VBA and continue it
until you have the functionality you want.

Microsoft.public.excel.programming etc.

HTH
--
-Larry-
--

"PC Datasheet" <no****@nospam.spam> wrote in message
news:P8*****************@newsread3.news.atl.earthl ink.net...
Export your data into a standard worksheet and in your pre-designed excel
worksheet use formulas to get the data from that worksheet.

--
PC Datasheet
Your Resource For Help With Access, Excel And Word Applications
re******@pcdatasheet.com
www.pcdatasheet.com
"Jonny" <jo**********@yahoo.com> wrote in message
news:14**************************@posting.google.c om...
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.


Nov 13 '05 #5

P: n/a
"Mr. Smith" <Mr.Smith@Large> wrote in message news:<40***********************@news.syd.swiftdsl. com.au>...
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

Thank you very much for this - I'll have a look at it.
Nov 13 '05 #6

This discussion thread is closed

Replies have been disabled for this discussion.