Not very efficient

[Edgar]

Hi

Can anyone suggest anything that I could do to the
following code to improve the efficiency of it as it is
running quite slow at the moment.

It copies values from separate sheets onto a template file
and then save as the template file.

TIA

Sub Create_Remittance()
Dim i As Integer
Dim sh As Worksheet
Dim File_Name As Workbook
Dim outfile As Workbook
Dim file_path As String

'Copies all values from sheets(sh) to Template file
For i = 5 To Sheets.Count
Set sh = Sheets(i)
sh.Activate
File_Name = ActiveWorkbook.Worksheets("Menu").Cells.Range
("D9").Value
Set outfile = Workbooks.Open(File_Name)
Windows("AU Remittance Module").Activate
file_path = Worksheets("Menu").Range("D12")

Range("B1").Copy
outfile.Worksheets("Remittance").Range("C6").PasteSpecial
Paste:=xlValues
Range("A1").Copy
outfile.Worksheets("Remittance").Range("C4").PasteSpecial
Paste:=xlValues
Range("C1").Copy
outfile.Worksheets("Remittance").Range("C8").PasteSpecial
Paste:=xlValues
Range("E1").Copy
outfile.Worksheets("Remittance").Range("C10").PasteSpecial
Paste:=xlValues
Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
outfile.Worksheets("Remittance").Range("A16").PasteSpecial
Paste:=xlValues
Range("D1" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
outfile.Worksheets("Remittance").Range("D16").PasteSpecial
Paste:=xlValues
Range("G1:G" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
outfile.Worksheets("Remittance").Range("C16").PasteSpecial
Paste:=xlValues
Range("H1:H" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
outfile.Worksheets("Remittance").Range("E16").PasteSpecial
Paste:=xlValues

outfile.Activate
Supp_Name = Range("C8")
Trans_No = Range("C10")
Supp_id = Range("C6")
Payment_Date = Range("c4")
Remit_Name = file_path & "\" & Supp_id & " " & Trans_No
& " " & Format(Payment_Date, "ddmmmyy") & ".xls"
ActiveWorkbook.SaveAs Remit_Name
ActiveWorkbook.Close

Next i
ActiveWorkbook.Sheets("Menu").Select

End Sub

 

[Guest]

The cells to which you are pasting are too "hard-coded" to use a more efficient means I think. You could precede your code with Application.ScreenUpdating = False, and then at the end, turn it back on. Application.ScreenUpdating = True

-Brad

 

[JE McGimpsey]

One way (with light testing):

Public Sub Create_Remittance()
Dim wsDest As Worksheet
Dim vPayment_Date As Variant
Dim vSupp_Id As Variant
Dim vSupp_Name As Variant
Dim vTrans_No As Variant
Dim i As Long
Dim nOldCalc As Long
Dim sFile_Name As String
Dim sFile_Path As String
Dim sRemit_Name As String

With Application
nOldCalc = .Calculation
.Calculation = xlManual
.ScreenUpdating = False
End With

With ActiveWorkbook
With .Sheets("Menu")
sFile_Name = .Range("D9").Value
sFile_Path = .Range("D12").Value
End With

For i = 5 To .Sheets.Count
Set wsDest = Workbooks.Open(sFile_Name).Sheets("Remittance")
With .Sheets(i)
vPayment_Date = .Range("A1")
vSupp_Id = .Range("B1").Value
vSupp_Name = .Range("C1").Value
vTrans_No = .Range("E1").Value
With .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp))
wsDest.Range("A16").Resize( _
.Rows.Count, .Columns.Count).Value = .Value
End With
With .Range("D1" & .Cells(Rows.Count, 1).End(xlUp))
wsDest.Range("D16").Resize( _
.Rows.Count, .Columns.Count).Value = .Value
End With
With .Range("G1:G" & .Cells(Rows.Count, 1).End(xlUp))
wsDest.Range("C16").Resize( _
.Rows.Count, .Columns.Count).Value = .Value
End With
With .Range("H1:H" & .Cells(Rows.Count, 1).End(xlUp))
wsDest.Range("E16").Resize( _
.Rows.Count, .Columns.Count).Value = .Value
End With
End With
With wsDest
wsDest.Range("C6").Value = vSupp_Id
wsDest.Range("C4").Value = vPayment_Date
wsDest.Range("C8").Value = vSupp_Name
wsDest.Range("C10").Value = vTrans_No
sRemit_Name = sFile_Path & Application.PathSeparator & _
vSupp_Id & " " & vTrans_No & " " & _
Format(vPayment_Date, "ddmmmyy") & ".xls"
With .Parent
.SaveAs sRemit_Name
.Close
End With
End With
Next i
End With

With Application
.Calculation = nOldCalc
.ScreenUpdating = True
End With

End Sub

 

[JE McGimpsey]

Lots of extra calculations in the previous one. Try:

Public Sub Create_Remittance()
Dim wsDest As Worksheet
Dim vPayment_Date As Variant
Dim vSupp_Id As Variant
Dim vSupp_Name As Variant
Dim vTrans_No As Variant
Dim i As Long
Dim nMax_Row As Long
Dim nOldCalc As Long
Dim sFile_Name As String
Dim sFile_Path As String
Dim sRemit_Name As String

With Application
nOldCalc = .Calculation
.Calculation = xlManual
.ScreenUpdating = False
End With

With ActiveWorkbook
With .Sheets("Menu")
sFile_Name = .Range("D9").Value
sFile_Path = .Range("D12").Value
End With

For i = 5 To .Sheets.Count
Set wsDest = Workbooks.Open(sFile_Name).Sheets("Remittance")
With .Sheets(i)
vPayment_Date = .Range("A1").Value
vSupp_Id = .Range("B1").Value
vSupp_Name = .Range("C1").Value
vTrans_No = .Range("E1").Value
nMax_Row = .Cells(.Rows.Count, 1).End(xlUp).Row
wsDest.Range("A16").Resize(nMax_Row, 1).Value = _
.Range("A1").Resize(nMax_Row, 1).Value
wsDest.Range("D16").Resize(nMax_Row, 1).Value = _
.Range("D1").Resize(nMax_Row, 1).Value
wsDest.Range("C16").Resize(nMax_Row, 1).Value = _
.Range("G1").Resize(nMax_Row, 1).Value
wsDest.Range("E16").Resize(nMax_Row, 1).Value = _
.Range("H1").Resize(nMax_Row, 1).Value
End With
With wsDest
wsDest.Range("C6").Value = vSupp_Id
wsDest.Range("C4").Value = vPayment_Date
wsDest.Range("C8").Value = vSupp_Name
wsDest.Range("C10").Value = vTrans_No
sRemit_Name = sFile_Path & Application.PathSeparator & _
vSupp_Id & " " & vTrans_No & " " & _
Format(vPayment_Date, "ddmmmyy") & ".xls"
With .Parent
.SaveAs sRemit_Name
.Close
End With
End With
Next i
End With

With Application
.Calculation = nOldCalc
.ScreenUpdating = True
End With

End Sub