How to increase the speed

[levanduyet]

Dear All,
I have the code as following:

Sub Copy_And_Format()

Dim arrColsWidth As Variant
Dim arrRowsHeight As Variant
Dim wsObjSource As Worksheet, wsObjReport As Worksheet
Dim lCol As Long, lRow As Long, lLastRow As Long
Dim lPasteTimesCount As Long, lTimesCount As Long
Dim rngSource As Range

On Error GoTo ErrorHandler
'Cac mang dinh dang Cot va Hang
arrColsWidth = Array(2.17, 1.83, 22.67, 7.5, 17.5, 22.83, 8.17, 11, 5)
arrRowsHeight = Array(11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 5, 10, _
10, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, _
11.25, 11.25, 11.25, 11.25, 10, 10, 11.25, 11.25, 11.25, 11.25, _
11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, _
11.25, 11.25, 11.25, 5, 10, 10, 11.25, 11.25, 11.25, 11.25, _
11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 10, _
10, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25, 11.25)
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'Dinh dang cot

Set wsObjSource = ThisWorkbook.Worksheets("Source")
Set wsObjReport = ThisWorkbook.Worksheets("Report")
Set rngSource = Application.Range("Format_Template")

'Hang cuoi cua worksheet Source
lLastRow = FindLastRow(wsObjSource)
'Xoa tat ca o worksheet Report
wsObjReport.Cells.Delete
'Copy tat ca du lieu qua worksheet Report
wsObjSource.Range("A1:I" & lLastRow).Copy
wsObjReport.Range("A1").PasteSpecial xlPasteValues
'Dinh dang font
Application.ThisWorkbook.Worksheets("Report").Select
wsObjReport.Cells.Select
With Selection.Font
.Name = "Courier New"
.Size = 8
End With
wsObjReport.Range("A1").Select

'Tinh so lan de dinh dang trang Report
lPasteTimesCount = (lLastRow \ 70) + 1
For lTimesCount = 1 To lPasteTimesCount
'Merge mot so o

With wsObjReport.Range("C" & ((lTimesCount - 1) * 70 + 10) & ":E" & ((lTimesCount - 1) * 70 + 11))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With

'2. Merge de tao ra Deductions

With wsObjReport.Range("F" & ((lTimesCount - 1) * 70 + 10) & ":I" & ((lTimesCount - 1) * 70 + 11))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
'3. Merge de tao ra Total Earnings

With wsObjReport.Range("C" & ((lTimesCount - 1) * 70 + 25) & ":E" & ((lTimesCount - 1) * 70 + 26))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
'4. Merge de tao ra Total Deductions

With wsObjReport.Range("F" & ((lTimesCount - 1) * 70 + 25) & ":I" & ((lTimesCount - 1) * 70 + 26))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
'5. Merge de tao ra so Net Payment

With wsObjReport.Range("H" & ((lTimesCount - 1) * 70 + 27) & ":I" & ((lTimesCount - 1) * 70 + 27))
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.MergeCells = True
End With
'Dan de tao ra border
rngSource.Copy
wsObjReport.Range("A" & ((lTimesCount - 1) * 70 + 1)).PasteSpecial xlPasteFormats
'Dinh dang do cao cua hang
With wsObjReport
.Cells(((lTimesCount - 1) * 70) + 9, 1).RowHeight = arrRowsHeight(8)
.Cells(((lTimesCount - 1) * 70) + 10, 1).RowHeight = arrRowsHeight(9)
.Cells(((lTimesCount - 1) * 70) + 11, 1).RowHeight = arrRowsHeight(10)
.Cells(((lTimesCount - 1) * 70) + 25, 1).RowHeight = arrRowsHeight(24)
.Cells(((lTimesCount - 1) * 70) + 26, 1).RowHeight = arrRowsHeight(25)
.Cells(((lTimesCount - 1) * 70) + 44, 1).RowHeight = arrRowsHeight(43)
.Cells(((lTimesCount - 1) * 70) + 45, 1).RowHeight = arrRowsHeight(44)
.Cells(((lTimesCount - 1) * 70) + 46, 1).RowHeight = arrRowsHeight(45)
.Cells(((lTimesCount - 1) * 70) + 59, 1).RowHeight = arrRowsHeight(58)
.Cells(((lTimesCount - 1) * 70) + 60, 1).RowHeight = arrRowsHeight(59)
End With
Application.StatusBar = "Making up to " & lTimesCount
Next lTimesCount

'Dinh dang do rong cot
Application.StatusBar = "Columns format..."
For lCol = 1 To 9
wsObjReport.Cells(1, lCol).ColumnWidth = arrColsWidth(lCol - 1)
Next lCol
'Dinh dang de Print Preview
Application.StatusBar = "Print setup..."
'With ActiveSheet.PageSetup
With wsObjReport.PageSetup
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
End With

MsgBox "Report have made.", vbInformation + vbOKOnly, "Note"

ErrorExit:
Set wsObjTemp = Nothing
'Giai phong bien
Set wsObjSource = Nothing
Set wsObjReport = Nothing
Set rngSource = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlCalculationManual
.StatusBar = False
End With
Exit Sub

ErrorHandler:
MsgBox "The error number: " & Err.Number & vbNewLine & _
"The error description: " & Err.Description, vbInformation + vbOKOnly, "Note"
Resume ErrorExit

End Sub

How can I increase the speed. It run very slow. Please see the attached file.

Tks,

LVD

[Kenneth Hobs]

See my kb entry: http://vbaexpress.com/kb/getarticle.php?kb_id=1035 (http://vbaexpress.com/forum/../kb/getarticle.php?kb_id=1035)

Try to design your code without .Select or .Activate. Only in a few cases will those be needed.

[levanduyet]

Thank Kenneth Hobs,
I have tested this file on the:

1. Excel 2003
2. Excel 2007

In the Excel 2003, the speed is very good.
In the Excel 2007, the speed is very slow.

I don't know, somethings is wrong with Excel 2007?
Anyone have tested it?

Le Van Duyet

[Bob Phillips]

I have just fired up an Excel 2007 VM and ran it and these are the results I got

Excel 2003 - .6875 secs
Excel 2007 VM - 1.21875 secs

77% slower but hardly a long time. Of course, the VM imposes an overhead as well so I fired an Excel 2003 VM and got

Excel 2003 VM - 1.07125 secs

55% slower than non VM Excel 2003.

The difference between Excel 2003 and 2007, both in a VM, was approximately 14% slower. Excel 2007 is known to be slower, but as your code is quick anyway, that hardly seems material.