Each week I manually export a db qry into an exel spreadsheet and as expected the spreadsheet size on average increases by about 273 records
Last week the spreadsheet size was 3,127kb but when I use the database to export the data the size increases to 70.6mb

The only difference is that this time I imported the data using the code below

Private Sub cmdForecastReport_Click()
DoCmd.SetWarnings True

Dim strQryName As String, strFilename As String, strDirectory As String, strFileDir As String
Dim appXL As New Excel.Application
Dim appXLBook As Excel.Workbook
Dim db As Database

Set db = CurrentDb()

strQryName = "qryProjectedIncomeForecast" 'Change to your query
strFilename = "Projected Income Forecast.xls" 'change to what you want to call the file
strDirectory = "P:\Database Cost reports\Forecast Reports" 'change to the folder you want
strFileDir = strDirectory & "\" & strFilename

DoCmd.OutputTo acOutputQuery, strQryName, acFormatXLS, strFileDir, False

Set appXLBook = GetObject(strFileDir)
Set appXL = appXLBook.Parent
appXL.Visible = True
appXLBook.Windows(1).Visible = True
appXL.DisplayAlerts = False
appXL.Columns("B:B").Select 'Change this to the column(s) you want formatted "0.00"
appXL.Selection.NumberFormat = "0.00"
appXL.Range("A1").Select
appXL.ActiveWorkbook.Save

DoCmd.SetWarnings True
End Sub


Is there a way to compress the spreadsheet or change it so it doesn't hog up the email system when i try & send these out?

thanks

Each week I manually export a db qry into an exel spreadsheet and as expected the spreadsheet size on average increases by about 273 records
Last week the spreadsheet size was 3,127kb but when I use the database to export the data the size increases to 70.6mb

The only difference is that this time I imported the data using the code below

Private Sub cmdForecastReport_Click()
DoCmd.SetWarnings True

Dim strQryName As String, strFilename As String, strDirectory As String, strFileDir As String
Dim appXL As New Excel.Application
Dim appXLBook As Excel.Workbook
Dim db As Database

Set db = CurrentDb()

strQryName = "qryProjectedIncomeForecast" 'Change to your query
strFilename = "Projected Income Forecast.xls" 'change to what you want to call the file
strDirectory = "P:\Database Cost reports\Forecast Reports" 'change to the folder you want
strFileDir = strDirectory & "\" & strFilename

DoCmd.OutputTo acOutputQuery, strQryName, acFormatXLS, strFileDir, False

Set appXLBook = GetObject(strFileDir)
Set appXL = appXLBook.Parent
appXL.Visible = True
appXLBook.Windows(1).Visible = True
appXL.DisplayAlerts = False
appXL.Columns("B:B").Select 'Change this to the column(s) you want formatted "0.00"
appXL.Selection.NumberFormat = "0.00"
appXL.Range("A1").Select
appXL.ActiveWorkbook.Save

DoCmd.SetWarnings True
End Sub


Is there a way to compress the spreadsheet or change it so it doesn't hog up the email system when i try & send these out?

thanks

Groundrush,

This is a code that I use to Zip large files, the first section is to be included in your code, as this will call the ZIP function, and will also define the workbook to zip and the path/file name once zipped.

' Calls the zip code and defines the Zip folder to add, and the folder to add to it
Call Zipp("I:\H925 Buying\E Rowe - Hong Kong\Department Exception reports\Department Import Exception Tracker " & strDate & ".zip", "I:\H925 Buying\E Rowe - Hong Kong\Department Exception reports\Department Import Exception Tracker " & strDate & ".xls")


This is the code that does the ZIP process work.


Public Function Zipp(ZipName, FileToZip)
'Zips A File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create OR ADD To
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim FSO As Object
Dim oApp As Object
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function

Hope this helps

Scott

This is causing your size problem:
appXL.Columns("B:B").Select 'Change this to the column(s) you want formatted "0.00"
appXL.Selection.NumberFormat = "0.00"


I found out for the current project I'm working on that if you format JUST the cells you have data in, and NOT the entire column or row then you will have a much smaller (and I mean MUCH smaller file). The reason is that the information needed for the workbook to store about which cells are formatted is much less if you only format certain cells as opposed to 65,000+ rows (if pre-2007 or 1 million+ in 2007) of a column.

Groundrush,

This is a code that I use to Zip large files, the first section is to be included in your code, as this will call the ZIP function, and will also define the workbook to zip and the path/file name once zipped.

' Calls the zip code and defines the Zip folder to add, and the folder to add to it
Call Zipp("I:\H925 Buying\E Rowe - Hong Kong\Department Exception reports\Department Import Exception Tracker " & strDate & ".zip", "I:\H925 Buying\E Rowe - Hong Kong\Department Exception reports\Department Import Exception Tracker " & strDate & ".xls")


This is the code that does the ZIP process work.


Public Function Zipp(ZipName, FileToZip)
'Zips A File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create OR ADD To
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim FSO As Object
Dim oApp As Object
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function

Hope this helps

Scott

Thanks, this will come in handy :-)

This is causing your size problem:
appXL.Columns("B:B").Select 'Change this to the column(s) you want formatted "0.00"
appXL.Selection.NumberFormat = "0.00"


I found out for the current project I'm working on that if you format JUST the cells you have data in, and NOT the entire column or row then you will have a much smaller (and I mean MUCH smaller file). The reason is that the information needed for the workbook to store about which cells are formatted is much less if you only format certain cells as opposed to 65,000+ rows (if pre-2007 or 1 million+ in 2007) of a column.

Bob,

I thought it was solved when I read your suggestion over the weekend but unfortuantly back at work I still have the same problem even after removing that piece of code.

I think my problem has something to do with part of the excel macro that I'm using.

I added code to copy & paste filtered data into seperate workbooks & I think it's causing the size problems

here is the code.

' Copy & paste data into relevent workborks
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="Admin Buildings"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("Adm").Select
ActiveWindow.Panes(1).Activate
Rows("1:1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="Commercial & Industrial"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("C&I").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="Croxteth Hall & Country Park"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("Crx Prk").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="Environmental Maintenance"
Cells.Select
Range("I5992").Activate
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets("Env Mnt").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="L & D Education"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("L&D Ed").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="LCC Non Repairs & Maintenance"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("Lcc 3rd Pty").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="Leisure Services"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("Lsure").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="Quote Register"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("Quote").Select
ActiveWindow.Panes(1).Activate
Rows("1:1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="St Georges Hall"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("St G Hall").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="Supported Living"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("S Liv").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="Third Party Schools"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("Sch 3rd Pty").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="Third Party Works"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("Non-Lcc 3rd Pty").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="Town Hall"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("T Hall").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=5, Criteria1:="P4 - PPM"
Cells.Select
Range("I5992").Activate
Selection.Copy
Sheets("PPM").Select
ActiveWindow.Panes(1).Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("All").Select
Application.CutCopyMode = False
Selection.AutoFilter Field:=5
Range("F2").Select
Range("A1:Q5991").Sort Key1:=Range("F2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

I do hope I don't need to lose this code as it's saving me a lot of repetitive work.


Any other suggestions would be most welcome

thanks

I've heard of this sort of thing before.

First goto the first empty cell after the last used row in your spreadsheet and then press ctrl+shift+down and then ctrl+shift+right, this should highlight all the unused rows in your spreadsheet, and then do Edit>Clear>All. Then do the same thing for all the unused columns to the right of your data. Save this and then take a look at the file size, it should be a normal size at this point, if it is a normal size just code this up and include it in your macro.

Thanks chergh

That does seem to help a little but the file size is still too big.

When I extract the data manually I don't get the size problem, its only when I replicate what I'm doing using the macro :confused:

Try using the CopyFromRecordSet method instead of the OutputTo method.




Private Sub cmdForecastReport_Click()
DoCmd.SetWarnings True

Dim strQryName As String, strFilename As String, strDirectory As String, strFileDir As String
Dim appXL As Excel.Application
Dim appXLBook As Excel.Workbook
Dim appXLws as Excel.worksheet
Dim db As Database
dim rs as recordset

Set db = CurrentDb()

strQryName = "qryProjectedIncomeForecast" 'Change to your query
strFilename = "Projected Income Forecast.xls" 'change to what you want to call the file
strDirectory = "P:\Database Cost reports\Forecast Reports" 'change to the folder you want
strFileDir = strDirectory & "\" & strFilename


set appXL= new excel.application
set appXLBook = appXL.workbooks.add
set appXLws = appXLBook.worksheets("Sheet1")

set rs = db.openrecordset(strQryName)

appXLws.range("A1").copyfromrecordset rs
appXLws.columns("B:B").numberformat = "0.00"

appXL.visible = true
appXLBook.Saveas strDirectory & "\" & strFilename

DoCmd.SetWarnings True
End Sub

GroundRush,

May seem like a silly question, but are you sure that you are just copying over the filtered data.

I produce a lot of macros whereby I filter data, copy it, and then paste it somewhere else, and I have found through trial and error that if I do not state that only the filtered section is to be copied, then the whole range regardless of the filter will be copied.

Try incorporating this piece of code into your work after the ' Cells Select' and before the copy function.

Selection.SpecialCells(xlCellTypeVisible).Select

This will only select the filtered section.

Thanks for all the replies & suggestions

I've been able to reduce the size by first Sorting the data before applying the filter.