export to excel from filtered datasheet

  • Thread starter Thread starter Mark Andrews
  • Start date Start date
M

Mark Andrews

I want to have a button to export data to Excel from a filtered datasheet
where the user also uses

DoCmd.RunCommand acCmdUnhideColumns to control which columns are shown and
which are hidden.

Also the datasheet has combo boxes so for example on cmbState "PA" might be
shown (but it is just 26 in the underlying recordset).

I would like to the excel export to look just like the datasheet does (10
out of 20 columns shown, show combo values etc...).

Can anyone help me out.
Mark

Here's what I usually use:
Public Sub ExportQueryToExcel(QueryName As String, sql As String, filepath
As String)
On Error GoTo Err_ExportQueryToExcel
'exports the specified query to the specified filepath
'Note: if sql <> "" then populate query with sql and save first before
exporting

Dim dbs As Database
Dim dbQueryDef As DAO.QueryDef

If (sql <> "") Then
Set dbs = CurrentDb()
Set dbQueryDef = dbs.QueryDefs(QueryName)
dbQueryDef.sql = sql
dbQueryDef.Close
End If
DoCmd.OutputTo acOutputQuery, QueryName, acFormatXLS, filepath
MsgBox "Export File Created: " & filepath, , "Export"

Exit_ExportQueryToExcel:
Set dbQueryDef = Nothing
Set dbs = Nothing
Exit Sub

Err_ExportQueryToExcel:
MsgBox Err.Description
Resume Exit_ExportQueryToExcel

End Sub
 
Mark,

Here is a procedure I wrote using a sample from Dev Ashish. It uses the
recordsetclone of the form and transfers it to an Excel spreadsheet. Mine
uses a continuous form so if you are using a Datasheet, put it onto another
main form so that you can use a button with it and address the
recordsetclone of the subform.

This uses automation and a DAO recordset. The procedure iterates through
the recordset and surgically (for lack of a better term) places that data
onto the spreadsheet cells, mimicking the form. On the form, there are
calculated fields for totals, so rather than just copying the values, I had
placed calculated cells on the spreadsheet so that they would change with
user input. That is on the end of the subroutine.

If you need to figure out how to reference something in Excel, for example,
how to address cells in the spreadsheet, just record a macro and use that as
a guide.


I can't send you my client's database. I hope this will help you.



Private Sub CreateXL_Click()
On Error GoTo errSec

'************ Code Start **********
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'

Dim objXL As Object
Dim objActiveWkb As Object
Dim rst As Recordset

[txtMessage] = "Creating Worksheet"
Me.Repaint


If fIsAppRunning("Excel", True) Then
Set objXL = GetObject(, "Excel.Application")
'boolXL = False
Else
Set objXL = CreateObject("Excel.Application")
'boolXL = True
End If

objXL.Visible = False

objXL.Application.Workbooks.Add
Set objActiveWkb = objXL.ActiveWorkbook

'Set Variable to Report Table
Dim iRow As Integer
Dim iCol As Integer
Set rst = Me.RecordsetClone



'Add Headings row
iRow = 1
objActiveWkb.Worksheets(1).Cells(iRow, 1) = "Synergy Tooling Systems"
iRow = 2
objActiveWkb.Worksheets(1).Cells(iRow, 1) = "Invoiced Orders Summary by
Customer Comparative Report"
iRow = 3

objActiveWkb.Worksheets(1).Cells(iRow, 7) = "Target"
objActiveWkb.Worksheets(1).Cells(iRow, 15) = "Comparative"
iRow = 4
objActiveWkb.Worksheets(1).Cells(iRow, 6) = " " & SetDate1() & " to " &
SetDate2()
objActiveWkb.Worksheets(1).Cells(iRow, 14) = " " & SetCompDate1() & "
to " & SetCompDate2()
iRow = 5
objActiveWkb.Worksheets(1).Cells(iRow, 1) = " "

With objActiveWkb.Worksheets(1)
.Rows("3:3").font.bold = True
.Rows("6:6").font.bold = True
End With

iRow = 6
objActiveWkb.Worksheets(1).Cells(iRow, 1) = "1,2..."
objActiveWkb.Worksheets(1).Cells(iRow, 1).ColumnWidth = 6
objActiveWkb.Worksheets(1).Cells(iRow, 2) = "Customer"
objActiveWkb.Worksheets(1).Cells(iRow, 2).ColumnWidth = 30
objActiveWkb.Worksheets(1).Cells(iRow, 3) = "Orders"
objActiveWkb.Worksheets(1).Cells(iRow, 3).ColumnWidth = 10
objActiveWkb.Worksheets(1).Cells(iRow, 3).HorizontalAlignment = -4152
'-4152 is value for Excel constant xlRight
objActiveWkb.Worksheets(1).Cells(iRow, 4) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 5) = "Sales"
objActiveWkb.Worksheets(1).Cells(iRow, 5).HorizontalAlignment = -4152
'Right align cell Sales
objActiveWkb.Worksheets(1).Cells(iRow, 6) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 7) = "Freight"
objActiveWkb.Worksheets(1).Cells(iRow, 7).HorizontalAlignment = -4152
'Right align cell Freight
objActiveWkb.Worksheets(1).Cells(iRow, 8) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 9) = "Ext"
objActiveWkb.Worksheets(1).Cells(iRow, 9).HorizontalAlignment = -4152
'Right align cell Ext
objActiveWkb.Worksheets(1).Cells(iRow, 10) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 11) = "Orders"
objActiveWkb.Worksheets(1).Cells(iRow, 12) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 13) = "Sales"
objActiveWkb.Worksheets(1).Cells(iRow, 13).HorizontalAlignment = -4152
'Right align cell Sales
objActiveWkb.Worksheets(1).Cells(iRow, 14) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 15) = "Freight"
objActiveWkb.Worksheets(1).Cells(iRow, 15).HorizontalAlignment = -4152
'Right align cell Freight
objActiveWkb.Worksheets(1).Cells(iRow, 16) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 17) = "Ext"
objActiveWkb.Worksheets(1).Cells(iRow, 17).HorizontalAlignment = -4152
'Right align cell Ext
objActiveWkb.Worksheets(1).Cells(iRow, 18) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 19) = "Variance"
objActiveWkb.Worksheets(1).Cells(iRow, 19).HorizontalAlignment = -4152
'Right align cell Ext
objActiveWkb.Worksheets(1).Cells(iRow, 20) = "Var Pct"
objActiveWkb.Worksheets(1).Cells(iRow, 20).HorizontalAlignment = -4152
'Right align cell Ext



'Format Data
Dim i As Integer
rst.MoveFirst
Do Until rst.EOF
i = i + 1
iRow = iRow + 1
[txtMessage1] = "Row " & iRow
Me.Repaint
With objActiveWkb
'Example cell assignments (Row, Col)
'.Worksheets(1).Cells(1, 1) = "1,1" 'Row1, Col1
'.Worksheets(1).Cells(2, 1) = "2,1" 'Row2, Col1
'.Worksheets(1).Cells(3, 1) = "3,1" 'Row3, Col1
'.Worksheets(1).Cells(1, 2) = "1,2" 'Row1, Col2
'.Worksheets(1).Cells(1, 3) = "1,3" 'Row1, Col2
'.Worksheets(1).Cells(iRow, 1) = Trim(rst![NumericOrder])
.Worksheets(1).Cells(iRow, 1) = i
.Worksheets(1).Cells(iRow, 1).HorizontalAlignment = -4108 'Align horiz
center
.Worksheets(1).Cells(iRow, 1).VerticalAlignment = -4108 'Align vert center
.Worksheets(1).Cells(iRow, 1).font.bold = True
.Worksheets(1).Cells(iRow, 2) = Trim(rst![Custname])
.Worksheets(1).Cells(iRow, 3) = Trim(rst![Orders])
.Worksheets(1).Cells(iRow, 4) = Trim(rst![OrdersPct])
.Worksheets(1).Cells(iRow, 4).NumberFormat = "0.00%" 'Set Percent format
for cell
.Worksheets(1).Cells(iRow, 5) = Trim(rst![SumPrice])
.Worksheets(1).Cells(iRow, 5).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 6) = Trim(rst![PricePct])
.Worksheets(1).Cells(iRow, 6).NumberFormat = "0.00%" 'Set Percent format
for cell
.Worksheets(1).Cells(iRow, 7) = Trim(rst![SumFrt])
.Worksheets(1).Cells(iRow, 7).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 8) = Trim(rst![FrtPct])
.Worksheets(1).Cells(iRow, 8).NumberFormat = "0.00%" 'Set Percent format
for cell
.Worksheets(1).Cells(iRow, 9) = Trim(rst![SumExt])
.Worksheets(1).Cells(iRow, 9).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 10) = Trim(rst![ExtPct])
.Worksheets(1).Cells(iRow, 10).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 11) = Trim(rst![compOrders])
.Worksheets(1).Cells(iRow, 12) = Trim(rst![compOrdersPct])
.Worksheets(1).Cells(iRow, 12).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 13) = Trim(rst![SumcompPrice])
.Worksheets(1).Cells(iRow, 13).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 14) = Trim(rst![compPricePct])
.Worksheets(1).Cells(iRow, 14).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 15) = Trim(rst![SumcompFrt])
.Worksheets(1).Cells(iRow, 15).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 16) = Trim(rst![compFrtPct])
.Worksheets(1).Cells(iRow, 16).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 17) = Trim(rst![SumcompExt])
.Worksheets(1).Cells(iRow, 17).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 18) = Trim(rst![CompExtPct])
.Worksheets(1).Cells(iRow, 18).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 19) = Trim(rst![Variance])
.Worksheets(1).Cells(iRow, 19).NumberFormat = "$#,##0.00;[Red]$#,##0.00"
'"$#,##0.00" 'Set Currency format for cell
.Worksheets(1).Cells(iRow, 20) = Trim(rst![VariancePCT])
.Worksheets(1).Cells(iRow, 20).NumberFormat = "0.00%" 'Set Percent
format for cell

End With
rst.MoveNext
Loop

'Add Totals Row here
iRow = iRow + 2
objActiveWkb.Worksheets(1).Cells(iRow, 2) = "Totals"
objActiveWkb.Worksheets(1).Cells(iRow, 3) = "=SUM(R" & 7 & "C" & 3 & ":R"
& iRow - 1 & "C" & 3 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 5) = "=SUM(R" & 7 & "C" & 5 & ":R"
& iRow - 1 & "C" & 5 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 5).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 7) = "=SUM(R" & 7 & "C" & 7 & ":R"
& iRow - 1 & "C" & 7 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 7).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 9) = "=SUM(R" & 7 & "C" & 9 & ":R"
& iRow - 1 & "C" & 9 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 9).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 11) = "=SUM(R" & 7 & "C" & 11 &
":R" & iRow - 1 & "C" & 11 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 13) = "=SUM(R" & 7 & "C" & 13 &
":R" & iRow - 1 & "C" & 13 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 13).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 15) = "=SUM(R" & 7 & "C" & 15 &
":R" & iRow - 1 & "C" & 15 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 15).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 17) = "=SUM(R" & 7 & "C" & 17 &
":R" & iRow - 1 & "C" & 17 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 17).NumberFormat = "$#,##0.00"



exitSec:
[txtMessage] = "Worksheet created!"
[txtMessage1] = ""
Me.Repaint
On Error Resume Next
objXL.Visible = True
Set objActiveWkb = Nothing
Set objXL = Nothing
rst.Close
Set rst = Nothing
Exit Sub

errSec:
objXL.Visible = True
If Err = 91 Then
Resume Next
Else
MsgBox "Error " & Err & ": " & Err.Description
Resume Next

End If

End Sub
 
Mark,

Thank you for sharing. Possibly I could make a routine that reads the
datasheet in some fashion and constructs the excel
file similar to how you do it? I don't think the recordsetclone knows which
columns are hidden?

I trying to get around three issues:
- only show columns that are currently visible in Access
- only show data similar to what is shown in the datasheet (for example one
column in the datasheet might be a combo box driven off ContactID, but to
the user
it display's "Smith, John". Each datasheet could have many of these combo
boxes.
- only show rows according to the current filter and in the order of the
current sort

I'm wondering if I could make a routine that I could put an Export to Excel
button on the main form to allow for exporting of the datasheet
and handle all of these conditions???

Do you think it's possible, or should I just try and construct the sql and
do a simple export?

I really only want column headings and data.

Any other input (from anyone) would be greatly beneficial,
Mark

Mark A. Sam said:
Mark,

Here is a procedure I wrote using a sample from Dev Ashish. It uses the
recordsetclone of the form and transfers it to an Excel spreadsheet. Mine
uses a continuous form so if you are using a Datasheet, put it onto
another main form so that you can use a button with it and address the
recordsetclone of the subform.

This uses automation and a DAO recordset. The procedure iterates through
the recordset and surgically (for lack of a better term) places that data
onto the spreadsheet cells, mimicking the form. On the form, there are
calculated fields for totals, so rather than just copying the values, I
had placed calculated cells on the spreadsheet so that they would change
with user input. That is on the end of the subroutine.

If you need to figure out how to reference something in Excel, for
example, how to address cells in the spreadsheet, just record a macro and
use that as a guide.


I can't send you my client's database. I hope this will help you.



Private Sub CreateXL_Click()
On Error GoTo errSec

'************ Code Start **********
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'

Dim objXL As Object
Dim objActiveWkb As Object
Dim rst As Recordset

[txtMessage] = "Creating Worksheet"
Me.Repaint


If fIsAppRunning("Excel", True) Then
Set objXL = GetObject(, "Excel.Application")
'boolXL = False
Else
Set objXL = CreateObject("Excel.Application")
'boolXL = True
End If

objXL.Visible = False

objXL.Application.Workbooks.Add
Set objActiveWkb = objXL.ActiveWorkbook

'Set Variable to Report Table
Dim iRow As Integer
Dim iCol As Integer
Set rst = Me.RecordsetClone



'Add Headings row
iRow = 1
objActiveWkb.Worksheets(1).Cells(iRow, 1) = "Synergy Tooling Systems"
iRow = 2
objActiveWkb.Worksheets(1).Cells(iRow, 1) = "Invoiced Orders Summary by
Customer Comparative Report"
iRow = 3

objActiveWkb.Worksheets(1).Cells(iRow, 7) = "Target"
objActiveWkb.Worksheets(1).Cells(iRow, 15) = "Comparative"
iRow = 4
objActiveWkb.Worksheets(1).Cells(iRow, 6) = " " & SetDate1() & " to "
& SetDate2()
objActiveWkb.Worksheets(1).Cells(iRow, 14) = " " & SetCompDate1() &
" to " & SetCompDate2()
iRow = 5
objActiveWkb.Worksheets(1).Cells(iRow, 1) = " "

With objActiveWkb.Worksheets(1)
.Rows("3:3").font.bold = True
.Rows("6:6").font.bold = True
End With

iRow = 6
objActiveWkb.Worksheets(1).Cells(iRow, 1) = "1,2..."
objActiveWkb.Worksheets(1).Cells(iRow, 1).ColumnWidth = 6
objActiveWkb.Worksheets(1).Cells(iRow, 2) = "Customer"
objActiveWkb.Worksheets(1).Cells(iRow, 2).ColumnWidth = 30
objActiveWkb.Worksheets(1).Cells(iRow, 3) = "Orders"
objActiveWkb.Worksheets(1).Cells(iRow, 3).ColumnWidth = 10
objActiveWkb.Worksheets(1).Cells(iRow, 3).HorizontalAlignment = -4152
'-4152 is value for Excel constant xlRight
objActiveWkb.Worksheets(1).Cells(iRow, 4) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 5) = "Sales"
objActiveWkb.Worksheets(1).Cells(iRow, 5).HorizontalAlignment = -4152
'Right align cell Sales
objActiveWkb.Worksheets(1).Cells(iRow, 6) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 7) = "Freight"
objActiveWkb.Worksheets(1).Cells(iRow, 7).HorizontalAlignment = -4152
'Right align cell Freight
objActiveWkb.Worksheets(1).Cells(iRow, 8) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 9) = "Ext"
objActiveWkb.Worksheets(1).Cells(iRow, 9).HorizontalAlignment = -4152
'Right align cell Ext
objActiveWkb.Worksheets(1).Cells(iRow, 10) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 11) = "Orders"
objActiveWkb.Worksheets(1).Cells(iRow, 12) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 13) = "Sales"
objActiveWkb.Worksheets(1).Cells(iRow, 13).HorizontalAlignment = -4152
'Right align cell Sales
objActiveWkb.Worksheets(1).Cells(iRow, 14) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 15) = "Freight"
objActiveWkb.Worksheets(1).Cells(iRow, 15).HorizontalAlignment = -4152
'Right align cell Freight
objActiveWkb.Worksheets(1).Cells(iRow, 16) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 17) = "Ext"
objActiveWkb.Worksheets(1).Cells(iRow, 17).HorizontalAlignment = -4152
'Right align cell Ext
objActiveWkb.Worksheets(1).Cells(iRow, 18) = ""
objActiveWkb.Worksheets(1).Cells(iRow, 19) = "Variance"
objActiveWkb.Worksheets(1).Cells(iRow, 19).HorizontalAlignment = -4152
'Right align cell Ext
objActiveWkb.Worksheets(1).Cells(iRow, 20) = "Var Pct"
objActiveWkb.Worksheets(1).Cells(iRow, 20).HorizontalAlignment = -4152
'Right align cell Ext



'Format Data
Dim i As Integer
rst.MoveFirst
Do Until rst.EOF
i = i + 1
iRow = iRow + 1
[txtMessage1] = "Row " & iRow
Me.Repaint
With objActiveWkb
'Example cell assignments (Row, Col)
'.Worksheets(1).Cells(1, 1) = "1,1" 'Row1, Col1
'.Worksheets(1).Cells(2, 1) = "2,1" 'Row2, Col1
'.Worksheets(1).Cells(3, 1) = "3,1" 'Row3, Col1
'.Worksheets(1).Cells(1, 2) = "1,2" 'Row1, Col2
'.Worksheets(1).Cells(1, 3) = "1,3" 'Row1, Col2
'.Worksheets(1).Cells(iRow, 1) = Trim(rst![NumericOrder])
.Worksheets(1).Cells(iRow, 1) = i
.Worksheets(1).Cells(iRow, 1).HorizontalAlignment = -4108 'Align horiz
center
.Worksheets(1).Cells(iRow, 1).VerticalAlignment = -4108 'Align vert
center
.Worksheets(1).Cells(iRow, 1).font.bold = True
.Worksheets(1).Cells(iRow, 2) = Trim(rst![Custname])
.Worksheets(1).Cells(iRow, 3) = Trim(rst![Orders])
.Worksheets(1).Cells(iRow, 4) = Trim(rst![OrdersPct])
.Worksheets(1).Cells(iRow, 4).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 5) = Trim(rst![SumPrice])
.Worksheets(1).Cells(iRow, 5).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 6) = Trim(rst![PricePct])
.Worksheets(1).Cells(iRow, 6).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 7) = Trim(rst![SumFrt])
.Worksheets(1).Cells(iRow, 7).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 8) = Trim(rst![FrtPct])
.Worksheets(1).Cells(iRow, 8).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 9) = Trim(rst![SumExt])
.Worksheets(1).Cells(iRow, 9).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 10) = Trim(rst![ExtPct])
.Worksheets(1).Cells(iRow, 10).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 11) = Trim(rst![compOrders])
.Worksheets(1).Cells(iRow, 12) = Trim(rst![compOrdersPct])
.Worksheets(1).Cells(iRow, 12).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 13) = Trim(rst![SumcompPrice])
.Worksheets(1).Cells(iRow, 13).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 14) = Trim(rst![compPricePct])
.Worksheets(1).Cells(iRow, 14).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 15) = Trim(rst![SumcompFrt])
.Worksheets(1).Cells(iRow, 15).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 16) = Trim(rst![compFrtPct])
.Worksheets(1).Cells(iRow, 16).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 17) = Trim(rst![SumcompExt])
.Worksheets(1).Cells(iRow, 17).NumberFormat = "$#,##0.00" 'Set Currency
format for cell
.Worksheets(1).Cells(iRow, 18) = Trim(rst![CompExtPct])
.Worksheets(1).Cells(iRow, 18).NumberFormat = "0.00%" 'Set Percent
format for cell
.Worksheets(1).Cells(iRow, 19) = Trim(rst![Variance])
.Worksheets(1).Cells(iRow, 19).NumberFormat = "$#,##0.00;[Red]$#,##0.00"
'"$#,##0.00" 'Set Currency format for cell
.Worksheets(1).Cells(iRow, 20) = Trim(rst![VariancePCT])
.Worksheets(1).Cells(iRow, 20).NumberFormat = "0.00%" 'Set Percent
format for cell

End With
rst.MoveNext
Loop

'Add Totals Row here
iRow = iRow + 2
objActiveWkb.Worksheets(1).Cells(iRow, 2) = "Totals"
objActiveWkb.Worksheets(1).Cells(iRow, 3) = "=SUM(R" & 7 & "C" & 3 & ":R"
& iRow - 1 & "C" & 3 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 5) = "=SUM(R" & 7 & "C" & 5 & ":R"
& iRow - 1 & "C" & 5 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 5).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 7) = "=SUM(R" & 7 & "C" & 7 & ":R"
& iRow - 1 & "C" & 7 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 7).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 9) = "=SUM(R" & 7 & "C" & 9 & ":R"
& iRow - 1 & "C" & 9 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 9).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 11) = "=SUM(R" & 7 & "C" & 11 &
":R" & iRow - 1 & "C" & 11 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 13) = "=SUM(R" & 7 & "C" & 13 &
":R" & iRow - 1 & "C" & 13 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 13).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 15) = "=SUM(R" & 7 & "C" & 15 &
":R" & iRow - 1 & "C" & 15 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 15).NumberFormat = "$#,##0.00"
objActiveWkb.Worksheets(1).Cells(iRow, 17) = "=SUM(R" & 7 & "C" & 17 &
":R" & iRow - 1 & "C" & 17 & ")"
objActiveWkb.Worksheets(1).Cells(iRow, 17).NumberFormat = "$#,##0.00"



exitSec:
[txtMessage] = "Worksheet created!"
[txtMessage1] = ""
Me.Repaint
On Error Resume Next
objXL.Visible = True
Set objActiveWkb = Nothing
Set objXL = Nothing
rst.Close
Set rst = Nothing
Exit Sub

errSec:
objXL.Visible = True
If Err = 91 Then
Resume Next
Else
MsgBox "Error " & Err & ": " & Err.Description
Resume Next

End If

End Sub
Click to expand...
 
Back
Top