Crispin

edited because I am thick


btw - it speeded it up to around ~3 secs on my machine.....

[Edited by Crispin - 5/1/2002 12:03:04 PM]

Fosters

This code takes 45 seconds, when you press the button! I really need to make it quicker!

The time is taken up with formatting the cells and columns.

Does anyone know a better way (without using a template) that will speed things up

(to run, copy into the form of a new project. Add a label1 and command1 and reference MS Excel Objects)

Option Explicit
Dim objExcel As Excel.Application
Dim objWorksheet As Excel.Worksheet
Const sFontName As String = "Arial"
Private Const XL_NOTRUNNING As Long = 429
Private Const Bold As Boolean = True
Private Const Regular As Boolean = False
Private Const Wrap As Boolean = True
Private Const NoWrap As Boolean = True

Private Sub Command1_Click()
Dim t As Double
Dim x As Long
Dim y As Long

t = Timer
Randomize t
Label1 = "Open"
OpenExcelSheet
Label1 = "page setup"
ExcelPageSetup
For y = 8 To 10
Label1 = "Load cells (row " & y - 7 & ")"
For x = 1 To 19
WriteCell Int(Rnd * 10000), x, y, sFontName, 8, Regular, "right"
Next x
Next y
Label1 = "Closing"
CloseExcelSheet
Label1 = Format(Timer - t, "#0.00") & " seconds"
End Sub

Sub OpenExcelSheet()
Set objExcel = Excel.Application
objExcel.Visible = False
objExcel.SheetsInNewWorkbook = 1
objExcel.Workbooks.Add
Set objWorksheet = objExcel.Worksheets("Sheet1")

End Sub
Sub CloseExcelSheet()
Dim sLoc As String
objWorksheet.SaveAs FileName:="c:\Excel test " & Format(Now, "dd.mm.yyyy HH.MM.SS") & ".xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
objExcel.Quit
Set objWorksheet = Nothing
Set objExcel = Nothing

End Sub
Sub ExcelPageSetup()
Label1 = "Formatting excel wooksheet (Page setup)"
With objWorksheet
'.Range("S1").Select
'.Pictures.Insert(App.Path & "\bmw_logo.bmp").Select
'With Selection
' .ShapeRange.ScaleWidth 0.66, 0, 0
' .ShapeRange.ScaleHeight 0.66, 0, 0
'End With

With .PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With


'line 1 header
Label1 = "Formatting excel wooksheet (Header line 1)"
WriteCell "A Subsidiary of a big group", 1, 1, sFontName, 6, Regular, "right"
.Range("A1").Select
With Selection
.VerticalAlignment = xlTop
.WrapText = True
End With
WriteCell "Another Limited Co", 2, 1, sFontName, 18, Bold, "left"
WriteCell Year(Now) - 1 & " - " & Year(Now), 8, 1, sFontName, 18, Bold, "left"


'line 2 employee header
Label1 = "Formatting excel wooksheet (Header line 2)"
WriteCell "000123", 1, 3, sFontName, 10, Bold, "Left"
WriteCell "Fosters", 4, 3, sFontName, 10, Bold, "Left"
WriteCell "AA000000A", 9, 3, sFontName, 10, Bold, "Left"

'line 3 Vehicles
Label1 = "Formatting excel wooksheet (Header line 3)"
WriteCell "Vehicles", 1, 5, sFontName, 10, Bold, "Left"
WriteCell "Mileage", 6, 6, sFontName, 9, Bold, "left"
WriteCell "Loan", 14, 6, sFontName, 9, Bold, "left"
WriteCell "Depreciation", 16, 6, sFontName, 9, Bold, "left"

'column headers and widths
Label1 = "Formatting excel wooksheet (Column headers)"
WriteCell "From", 1, 7, sFontName, 8, Bold, "left": .Columns(1).ColumnWidth = 9.14
WriteCell "To", 2, 7, sFontName, 8, Bold, "left": .Columns(2).ColumnWidth = 9.14
WriteCell "PPN", 3, 7, sFontName, 8, Bold, "left": .Columns(3).ColumnWidth = 3.71
WriteCell "Reg No", 4, 7, sFontName, 8, Bold, "left": .Columns(4).ColumnWidth = 8.43
WriteCell "Model", 5, 7, sFontName, 8, Bold, "left": .Columns(5).ColumnWidth = 11
WriteCell "Business", 6, 7, sFontName, 8, Bold, "left": .Columns(6).ColumnWidth = 7.29
WriteCell "Private", 7, 7, sFontName, 8, Bold, "left": .Columns(7).ColumnWidth = 5.75
WriteCell "PMR", 8, 7, sFontName, 8, Bold, "left": .Columns(8).ColumnWidth = 4
WriteCell "Ins", 9, 7, sFontName, 8, Bold, "left": .Columns(9).ColumnWidth = 3
WriteCell "Maint", 10, 7, sFontName, 8, Bold, "left": .Columns(10).ColumnWidth = 5
WriteCell "RFL", 11, 7, sFontName, 8, Bold, "left": .Columns(11).ColumnWidth = 4.3
WriteCell "PDI", 12, 7, sFontName, 8, Bold, "left": .Columns(12).ColumnWidth = 4.14
WriteCell "Amount", 13, 7, sFontName, 8, Bold, "left": .Columns(13).ColumnWidth = 6.86
WriteCell "Benefit", 14, 7, sFontName, 8, Bold, "left": .Columns(14).ColumnWidth = 6.3
WriteCell "Residual", 15, 7, sFontName, 8, Bold, "left": .Columns(15).ColumnWidth = 6.86
WriteCell "Amount", 16, 7, sFontName, 8, Bold, "left": .Columns(16).ColumnWidth = 6.43
WriteCell "Benefit", 17, 7, sFontName, 8, Bold, "left": .Columns(17).ColumnWidth = 6
WriteCell "Fuel", 18, 7, sFontName, 8, Bold, "left": .Columns(18).ColumnWidth = 6.29
WriteCell "Total", 19, 7, sFontName, 8, Bold, "left": .Columns(19).ColumnWidth = 8.43

End With
End Sub
Sub WriteCell(sText As String, lCol As Long, lRow As Long, sFontName As String, _
iFontSize As Integer, bBold As Boolean, sAlignment As String)

With objWorksheet
If Left(sText, 1) = "'" Then
.Cells(lRow, lCol).Value = sText
Else
.Cells(lRow, lCol).Formula = sText
End If
.Cells(lRow, lCol).Font.Name = sFontName
.Cells(lRow, lCol).Font.Size = iFontSize
.Cells(lRow, lCol).Font.Bold = IIf(bBold, True, False)
.Cells(lRow, lCol).VerticalAlignment = xlTop
.Cells(lRow, lCol).HorizontalAlignment = IIf(LCase(sAlignment) = "left", xlLeft, xlRight)
'.Cells(lRow, lCol).Font.Color = RGB(255,0,0)
End With
End Sub

Crispin

Hi Fosters,

When you do a .PageSetup in VB/VBA it makes a call to your printer to validate your settings (for every property you set!!), this is what causes the delays....heres some new code for you using an Excel 4 macro (I know it seems silly to do it like this, but hey it works, and its faster than XL95,97,2000, and 2002)...

hope this helps


Option Explicit
Dim objExcel As Excel.Application
Dim objWorksheet As Excel.Worksheet
Const sFontName As String = "Arial"
Private Const XL_NOTRUNNING As Long = 429
Private Const Bold As Boolean = True
Private Const Regular As Boolean = False
Private Const Wrap As Boolean = True
Private Const NoWrap As Boolean = True

Private Sub Command1_Click()
Dim t As Double
Dim x As Long
Dim y As Long

t = Timer
Randomize t
Label1 = "Open"
OpenExcelSheet
Label1 = "page setup"
ExcelPageSetup
For y = 8 To 10
Label1 = "Load cells (row " & y - 7 & ")"
For x = 1 To 19
WriteCell Int(Rnd * 10000), x, y, sFontName, 8, Regular, "right"
Next x
Next y
Label1 = "Closing"
CloseExcelSheet
Label1 = Format(Timer - t, "#0.00") & " seconds"
End Sub

Sub OpenExcelSheet()
Set objExcel = Excel.Application
objExcel.Visible = False
objExcel.SheetsInNewWorkbook = 1
objExcel.Workbooks.Add
Set objWorksheet = objExcel.Worksheets("Sheet1")
End Sub
Sub CloseExcelSheet()
Dim sLoc As String
objWorksheet.SaveAs FileName:="c:\Excel test " & Format(Now, "dd.mm.yyyy HH.MM.SS") & ".xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
objExcel.Quit
Set objWorksheet = Nothing
Set objExcel = Nothing

End Sub
Sub ExcelPageSetup()
Label1 = "Formatting excel wooksheet (Page setup)"
With objWorksheet
.Range("S1").Select
.Pictures.Insert(App.Path & "\bmw_logo.bmp").Select
With Selection
.ShapeRange.ScaleWidth 0.66, 0, 0
.ShapeRange.ScaleHeight 0.66, 0, 0
End With
'USE EXCEL 4 MACRO INSTEAD OF VB OBJECT THAT MAKES PRINTER CALLS....
PgSetup
'With .PageSetup
'.LeftHeader = ""
'.CenterHeader = ""
'.RightHeader = ""
'.LeftFooter = ""
'.CenterFooter = ""
'.RightFooter = ""
'.LeftMargin = Application.InchesToPoints(0.5)
'.RightMargin = Application.InchesToPoints(0.5)
'.TopMargin = Application.InchesToPoints(1)
'.BottomMargin = Application.InchesToPoints(1)
'.HeaderMargin = Application.InchesToPoints(0.5)
'.FooterMargin = Application.InchesToPoints(0.5)
'.PrintHeadings = False
'.PrintGridlines = False
'.PrintComments = xlPrintNoComments
'.PrintQuality = 600
'.CenterHorizontally = False
'.CenterVertically = False
'.Orientation = xlLandscape
'.Draft = False
'.PaperSize = xlPaperA4
'.FirstPageNumber = xlAutomatic
'.Order = xlDownThenOver
'.BlackAndWhite = False
'.Zoom = 100
'End With


'line 1 header
Label1 = "Formatting excel wooksheet (Header line 1)"
WriteCell "A Subsidiary of a big group", 1, 1, sFontName, 6, Regular, "right"
.Range("A1").Select
With Selection
.VerticalAlignment = xlTop
.WrapText = True
End With
WriteCell "Another Limited Co", 2, 1, sFontName, 18, Bold, "left"
WriteCell Year(Now) - 1 & " - " & Year(Now), 8, 1, sFontName, 18, Bold, "left"


'line 2 employee header
Label1 = "Formatting excel wooksheet (Header line 2)"
WriteCell "000123", 1, 3, sFontName, 10, Bold, "Left"
WriteCell "Fosters", 4, 3, sFontName, 10, Bold, "Left"
WriteCell "AA000000A", 9, 3, sFontName, 10, Bold, "Left"

'line 3 Vehicles
Label1 = "Formatting excel wooksheet (Header line 3)"
WriteCell "Vehicles", 1, 5, sFontName, 10, Bold, "Left"
WriteCell "Mileage", 6, 6, sFontName, 9, Bold, "left"
WriteCell "Loan", 14, 6, sFontName, 9, Bold, "left"
WriteCell "Depreciation", 16, 6, sFontName, 9, Bold, "left"

'column headers and widths
Label1 = "Formatting excel wooksheet (Column headers)"
WriteCell "From", 1, 7, sFontName, 8, Bold, "left": .Columns(1).ColumnWidth = 9.14
WriteCell "To", 2, 7, sFontName, 8, Bold, "left": .Columns(2).ColumnWidth = 9.14
WriteCell "PPN", 3, 7, sFontName, 8, Bold, "left": .Columns(3).ColumnWidth = 3.71
WriteCell "Reg No", 4, 7, sFontName, 8, Bold, "left": .Columns(4).ColumnWidth = 8.43
WriteCell "Model", 5, 7, sFontName, 8, Bold, "left": .Columns(5).ColumnWidth = 11
WriteCell "Business", 6, 7, sFontName, 8, Bold, "left": .Columns(6).ColumnWidth = 7.29
WriteCell "Private", 7, 7, sFontName, 8, Bold, "left": .Columns(7).ColumnWidth = 5.75
WriteCell "PMR", 8, 7, sFontName, 8, Bold, "left": .Columns(8).ColumnWidth = 4
WriteCell "Ins", 9, 7, sFontName, 8, Bold, "left": .Columns(9).ColumnWidth = 3
WriteCell "Maint", 10, 7, sFontName, 8, Bold, "left": .Columns(10).ColumnWidth = 5
WriteCell "RFL", 11, 7, sFontName, 8, Bold, "left": .Columns(11).ColumnWidth = 4.3
WriteCell "PDI", 12, 7, sFontName, 8, Bold, "left": .Columns(12).ColumnWidth = 4.14
WriteCell "Amount", 13, 7, sFontName, 8, Bold, "left": .Columns(13).ColumnWidth = 6.86
WriteCell "Benefit", 14, 7, sFontName, 8, Bold, "left": .Columns(14).ColumnWidth = 6.3
WriteCell "Residual", 15, 7, sFontName, 8, Bold, "left": .Columns(15).ColumnWidth = 6.86
WriteCell "Amount", 16, 7, sFontName, 8, Bold, "left": .Columns(16).ColumnWidth = 6.43
WriteCell "Benefit", 17, 7, sFontName, 8, Bold, "left": .Columns(17).ColumnWidth = 6
WriteCell "Fuel", 18, 7, sFontName, 8, Bold, "left": .Columns(18).ColumnWidth = 6.29
WriteCell "Total", 19, 7, sFontName, 8, Bold, "left": .Columns(19).ColumnWidth = 8.43

End With
End Sub
Sub WriteCell(sText As String, lCol As Long, lRow As Long, sFontName As String, _
iFontSize As Integer, bBold As Boolean, sAlignment As String)

With objWorksheet
If Left(sText, 1) = "'" Then
.Cells(lRow, lCol).Value = sText
Else
.Cells(lRow, lCol).Formula = sText
End If
.Cells(lRow, lCol).Font.Name = sFontName
.Cells(lRow, lCol).Font.Size = iFontSize
.Cells(lRow, lCol).Font.Bold = IIf(bBold, True, False)
.Cells(lRow, lCol).VerticalAlignment = xlTop
.Cells(lRow, lCol).HorizontalAlignment = IIf(LCase(sAlignment) = "left", xlLeft, xlRight)
'.Cells(lRow, lCol).Font.Color = RGB(255,0,0)
End With
End Sub

Public Sub PgSetup()
Dim pStr$
pStr = "PAGE.SETUP(,,.5,.5,1,1,False,False,False,False,2, 9,True," & Chr(34) & "Auto" & Chr(34) & ",1,False," & Chr(34) & "620" & Chr(34) & ",0.5,0.5,False,False)"
'PAGE.SETUP(head, foot, left, right, top, bot, hdng, grid, h_cntr, v_cntr, orient, paper_size, scale, pg_num, pg_order, bw_cells, quality, head_margin, foot_margin, notes, draft)
Application.ExecuteExcel4Macro pStr
End Sub

Fosters

That's cut down a report production from 50 seconds to 8!!

You're a fecking star!!!

Beers are on me!

stu200

iTrader: (1)

To cut down on the remaining 8 seconds (from memory), add a call to ...

Application.ScreenUpdating = False
doAllTheFormattingStuff()
Application.ScreenUpdating = True

Fosters

Unfortunately the excel4 macro didn't work . I've cut the 50+ seconds to 45 and (thanks stu200 ) with the screen update off that's down to 38.

I tried the excel4 macro in isolation (in excel actually) and none of the page properties were set. The macro didn't give an error tho'

Any ideas anyone?

Crispin

???

....what page props weren't set...

Fosters

didn't set the margins, or the page orientation.

I've given up an done an excel template
does the whole lot in under 6 seconds now.

Crispin

soz m8, worked for me.....