T
tudorpe
Any idea why this code is so slow? It used to run fine it now take
around 20 seconds to complete
any help would be appriciated.
Sub record_new_record()
Dim prev As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Sheets("Records").Unprotect
Sheets("Records").Select
Range("A1").End(xlDown).Offset(1, 0).Select
prev = ActiveCell.Offset(rowoffset:=-1, columnoffset:=0).Value
Selection.Value = prev + 1
ActiveCell.Next.Select
' gives record an individual number automatically
Sheets("OEE").Range("b1").Copy
Sheets("Records").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
' pastes date
ActiveCell.Next.Select
Sheets("OEE").Range("d5").Copy
Sheets("Records").Select
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'ActiveCell.Next.Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(3, R[0]C[-59])"
ActiveCell.Next.Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-58], Products, 29, FALSE)"
ActiveCell.Copy
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ActiveCell.Next.Select
'' LOTS MORE CUT & PASTE BITS HERE
Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select ' formats used rows
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = False
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
Cells.Select
With Selection.Validation ' remove validation from cells
.Delete ' which have been copied
End With ' from Sheet
Selection.Columns.AutoFit
Selection.Font.ColorIndex = 0 ' end of row formatting
Range("a2").Select
Sheets("Records").Protect ' protects sheet
Sheets("OEE").Select
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Dim Msg, Style, Title, Response
Msg = "Do you want to clear the screen?" ' Define message.
Style = vbYesNo + vbQuestion + vbDefaultButton2 ' Define buttons.
Title = "Reset Form" ' Define title.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
Application.Run "'Line 15 OEE.xls'!Module6.clear"
End If
End Su
around 20 seconds to complete
any help would be appriciated.
Sub record_new_record()
Dim prev As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Sheets("Records").Unprotect
Sheets("Records").Select
Range("A1").End(xlDown).Offset(1, 0).Select
prev = ActiveCell.Offset(rowoffset:=-1, columnoffset:=0).Value
Selection.Value = prev + 1
ActiveCell.Next.Select
' gives record an individual number automatically
Sheets("OEE").Range("b1").Copy
Sheets("Records").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
' pastes date
ActiveCell.Next.Select
Sheets("OEE").Range("d5").Copy
Sheets("Records").Select
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'ActiveCell.Next.Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(3, R[0]C[-59])"
ActiveCell.Next.Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-58], Products, 29, FALSE)"
ActiveCell.Copy
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ActiveCell.Next.Select
'' LOTS MORE CUT & PASTE BITS HERE
Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select ' formats used rows
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = False
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
Cells.Select
With Selection.Validation ' remove validation from cells
.Delete ' which have been copied
End With ' from Sheet
Selection.Columns.AutoFit
Selection.Font.ColorIndex = 0 ' end of row formatting
Range("a2").Select
Sheets("Records").Protect ' protects sheet
Sheets("OEE").Select
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Dim Msg, Style, Title, Response
Msg = "Do you want to clear the screen?" ' Define message.
Style = vbYesNo + vbQuestion + vbDefaultButton2 ' Define buttons.
Title = "Reset Form" ' Define title.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
Application.Run "'Line 15 OEE.xls'!Module6.clear"
End If
End Su