levanduyet
02-26-2009, 10:09 PM
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
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