Inefficient code

Hi

I have written some code (pasted below), my issue is that it is very cludgey in performance during the read write loop. It is reading in my sample 120 lines and writing 70 output lines. This is taking in the region of 30 secs. I think I can guess why, but given what I want to do I'm not sure how I can rectify. Any pointers would be helpful. I think the probable cause is that I am reading from one workbook and writing to a different workbook. I do need to write to another book because the O/P file will be used to import into our financial system. I have pasted the full code beneath. It's the LoopThruProjects that is the time gobbler.


Option Explicit
Private ReportWb As Workbook 'Output workbook
Private ProjectWb As Workbook 'Source project details
'Private iReport As Integer
Private iLastReportedRow 'this is not the same as iLastRow, this gets last reported row, not last project row
Private iLastRow As Integer 'Last project row in source workbook
Private iRowCounter As Integer 'Counter for input row loop
Private iWriteCounter ' This counter is used to ensure no blank lines written to O/P, blank lines occur if iRowCounter used

Sub Main()
' This vb
' calls sub to create a new work book to write the project detail report to (closes if already open)
' calls sub to create the header row in the new wb
' Calls a sub to Loop down the source until it hits a blank cell, for each project row, details are copied to target wb
' Calls sub to tidy up the output workbook

Application.ScreenUpdating = False

' Dim ReportWs As Worksheet

'set variables
Set ProjectWb = ThisWorkbook
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row 'get last row for column B (all projects added)
iLastReportedRow = Cells(Rows.Count, 1).End(xlUp).Row ' gets last row for projects reported
iLastReportedRow = iLastReportedRow + 1 'Set counter to next empty reported row

Call PrepareOutputfile
Call CreateHeader 'Create header in target wb

ProjectWb.Activate 'make source wb active
Cells(iLastReportedRow, 2).Select

iWriteCounter = 2

Call LoopThruProjects
Call TidyupOutput

ProjectWb.Activate
'ReportWb.Close
End Sub
Sub PrepareOutputfile()
'Close if open then save as output workbook

Application.DisplayAlerts = False

On Error Resume Next
Workbooks("ReportForEvision").Close


Workbooks.Add 'Add workbook
ActiveWorkbook.SaveAs Filename:="H:\ReportForEvision.xlsx"
Application.DisplayAlerts = True

Set ReportWb = Workbooks("ReportForEvision.xlsx")
End Sub

Sub LoopThruProjects()
For iRowCounter = iLastReportedRow To iLastRow 'loop through each source project row
If ActiveCell.Offset(0, 5) <> "Archived" And ActiveCell.Offset(0, 5) <> "Cancelled" _
And ActiveCell.Offset(0, 5) <> "Tender" Then '
ActiveCell.Offset(0, -1) = "Project Reported"
Call CopyCells 'copy source details to target wb
iWriteCounter = iWriteCounter + 1
Else ' has not been reported but does not have a valid status
ActiveCell.Offset(0, -1) = "Project Status - Ignored for Evision" 'Not an active status, do not report
End If
ActiveCell.Offset(1, 0).Select
Next iRowCounter
ReportWb.Activate
Cells.Select
Cells.EntireColumn.AutoFit
End Sub

Sub CreateHeader()
' This called sub creates the target wb header row
Application.ScreenUpdating = False
[a1].Select
Dim MyCounter As Integer
MyCounter = 1
Do While MyCounter < 13
Select Case MyCounter
Case Is = 1
ActiveCell = "Project Name"
Case Is = 2
ActiveCell = "Completion Date"
Case Is = 3
ActiveCell = "Agreed Contract Sum"
Case Is = 4
ActiveCell = "Contract Period"
Case Is = 5
ActiveCell = "Possession Date"
Case Is = 6
ActiveCell = "DLP Period"
Case Is = 7
ActiveCell = "DLP Starts"
Case Is = 8
ActiveCell = "DLP Expiry"
Case Is = 9
ActiveCell = "LOI"
Case Is = 10
ActiveCell = "LOI Cap"
Case Is = 11
ActiveCell = "Retention"
Case Is = 12
ActiveCell = "Project Status"
End Select
MyCounter = MyCounter + 1
ActiveCell.Offset(0, 1).Select
Loop
Cells.Select
Cells.EntireColumn.AutoFit
Range("B:B,E:E,G:G,H:H").Select
Range("H1").Activate
Selection.NumberFormat = "dd/mm/yyyy;@"
Columns("C:C").Select
Selection.NumberFormat = "£#,##0"
Columns("D:D").Select
Selection.NumberFormat = "0"
[a2].Select
End Sub

Sub CopyCells()
' This called sub copies the project details to ReportForEvision

Application.ScreenUpdating = False

Dim iCopy As Integer
Dim Target

Set Target = ReportWb.Worksheets("sheet1")

Cells(iRowCounter, 4).Copy
Target.Cells(iWriteCounter, 1).PasteSpecial xlPasteValues
Range("b" & iRowCounter).Offset(0, 13).Copy
Target.Range("b" & iWriteCounter).PasteSpecial xlPasteValues 'Completion Date
Range("b" & iRowCounter).Offset(0, 14).Copy
Target.Range("c" & iWriteCounter).PasteSpecial xlPasteValues 'Contract Sum
Range("b" & iRowCounter).Offset(0, 17).Copy
Target.Range("d" & iWriteCounter).PasteSpecial xlPasteValues 'Contract Period
Range("b" & iRowCounter).Offset(0, 18).Copy
Target.Range("e" & iWriteCounter).PasteSpecial xlPasteValues 'Possession Date
Range("b" & iRowCounter).Offset(0, 19).Copy
Target.Range("f" & iWriteCounter).PasteSpecial xlPasteValues 'DLP in weeks
Range("b" & iRowCounter).Offset(0, 20).Copy
Target.Range("g" & iWriteCounter).PasteSpecial xlPasteValues 'DLP Starts
Range("b" & iRowCounter).Offset(0, 21).Copy
Target.Range("h" & iWriteCounter).PasteSpecial xlPasteValues 'DLP Expiry
Range("b2").Offset(0, 22).Copy
Target.Range("i" & iWriteCounter).PasteSpecial xlPasteValues 'LOI
Range("b" & iRowCounter).Offset(0, 23).Copy
Target.Range("j" & iWriteCounter).PasteSpecial xlPasteValues 'LOI Cap
Range("b" & iRowCounter).Offset(0, 24).Copy
Target.Range("k" & iWriteCounter).PasteSpecial xlPasteValues 'Retention
Range("b" & iRowCounter).Offset(0, 5).Copy
Target.Range("l" & iWriteCounter).PasteSpecial xlPasteValues 'Project Status
End Sub

Sub TidyupOutput()
'Put borders around cells
Dim xlEdgeType As Variant
For Each xlEdgeType In Array(xlEdgeLeft, xlEdgeTop, xlEdgeRight, _
xlEdgeBottom, xlInsideVertical, xlInsideHorizontal)
Range("A1").CurrentRegion.Select
With Selection.Borders(xlEdgeType)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Next xlEdgeType
[a1].Select
End Sub