Script works very slow!

D

dzelnio

The following script does some fairly simple stuff.
1. Find all unique records with the latest date (from Details)
2. Puts those records on Worksheet2 (aka Summary)
3. Converts dates from text to date form

Can anyone see anything in here that would make it soooo slow?



Option Explicit
Sub Summary()
Dim lastrow As Long, path As String, today As Long, Ans As Variant

Application.ScreenUpdating = False
Sheets("Summary").Select
Rows("2:3000").ClearContents

Sheets("Details").Select
lastrow = Cells(3000, 1).End(xlUp).Row
Range(Cells(2, 5), Cells(lastrow, 5)).Select
Selection.FormulaR1C1 = "=DATEVALUE(MID(RC[-3],FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1)+1,FIND("","",RC[-3],FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1))-FIND("" "",RC[-3],FIND("" "",RC[-3])
+1+1)-1) & ""-"" & LEFT(MID(RC[-3],FIND("" "",RC[-3])+1,FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1)-FIND("" "",RC[-3])+1),3) & "" -"" &
MID(RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND("" "",RC[-3])+1+1))
+2,FIND("" "",RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND(""
"",RC[-3])+1+1))+2)-FIND("","",RC[-3],FIND("" "",RC[-3],FIND(""
"",RC[-3])+1+1))-2))+TIMEVALUE(MID(RC[-3],FIND(""
"",RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND("" "",RC[-3])+1+1))
+2)+1,15))"
Selection.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
Selection.Copy
Cells(2, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Selection.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("E:E").ClearContents

Sheets("Summary").Select
Range(Sheets("Details").Cells(3, 1), Sheets("Details").Cells(lastrow,
4)).Copy Cells(2, 1)


lastrow = Cells(3000, 1).End(xlUp).Row
Columns("A:E").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Key2:=Range("B2") _
, Order2:=xlDescending, Header:=xlYes, OrderCustom:=1,
MatchCase:= _
False, Orientation:=xlTopToBottom
Range(Cells(2, 5), Cells(lastrow, 5)).FormulaR1C1 =
"=IF(RC1<>R[-1]C1,""Y"",""N"")"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.Sort Key1:=Range("E2"), Order1:=xlDescending,
Key2:=Range("A2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1,
MatchCase:= _
False, Orientation:=xlTopToBottom

Ans = Application.CountIf(Columns("E"), "Y")
Rows(Ans + 2 & ":" & 3000).ClearContents
Columns("E").ClearContents
ActiveWindow.ScrollRow = 2
Cells(2, 1).Select
End Sub
 
T

Trevor Shuttleworth

Can't test this properly because I don't know what the data looks like.

Try to avoid selecting cells wherever possible. For example:

Option Explicit
Sub Summary()
Dim lastrow As Long, path As String, today As Long, Ans As Variant

Application.ScreenUpdating = False
Sheets("Summary").Select
Rows("2:3000").ClearContents

Sheets("Details").Select
lastrow = Cells(3000, 1).End(xlUp).Row
With Range(Cells(2, 5), Cells(lastrow, 5))
.FormulaR1C1 = "=DATEVALUE(MID(RC[-3],FIND("""",RC[-3],FIND(""
"",RC[-3])+1+1)+1,FIND("","",RC[-3],FIND("""",RC[-3],FIND(""
"",RC[-3])+1+1))-FIND("" "",RC[-3],FIND("" "",RC[-3])+1+1)-1) & ""-"" &
LEFT(MID(RC[-3],FIND("" "",RC[-3])+1,FIND("""",RC[-3],FIND(""
"",RC[-3])+1+1)-FIND("" "",RC[-3])+1),3) & "" -"" &
MID(RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND(""
"",RC[-3])+1+1))+2,FIND("" "",RC[-3],FIND("","",RC[-3],FIND(""
"",RC[-3],FIND("""",RC[-3])+1+1))+2)-FIND("","",RC[-3],FIND(""
"",RC[-3],FIND("""",RC[-3])+1+1))-2))+TIMEVALUE(MID(RC[-3],FIND("""",RC[-3],FIND("","",RC[-3],FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1))+2)+1,15))"
.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
.Copy
End With
With Cells(2, 2)
.PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With
With Columns("B:B")
.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("E:E").ClearContents

Sheets("Summary").Select
Range(Sheets("Details").Cells(3, 1), Sheets("Details").Cells(lastrow,
4)).Copy Cells(2, 1)

lastrow = Cells(3000, 1).End(xlUp).Row
Columns("A:E").Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
With Range(Cells(2, 5), Cells(lastrow, 5))
.FormulaR1C1 = "=IF(RC1<>R[-1]C1,""Y"",""N"")"
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Sort Key1:=Range("E2"), Order1:=xlDescending, _
Key2:=Range("A2"), Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

Ans = Application.CountIf(Columns("E"), "Y")
Rows(Ans + 2 & ":" & 3000).ClearContents
Columns("E").ClearContents
ActiveWindow.ScrollRow = 2
Cells(2, 1).Select
End Sub

Regards

Trevor


dzelnio said:
The following script does some fairly simple stuff.
1. Find all unique records with the latest date (from Details)
2. Puts those records on Worksheet2 (aka Summary)
3. Converts dates from text to date form

Can anyone see anything in here that would make it soooo slow?



Option Explicit
Sub Summary()
Dim lastrow As Long, path As String, today As Long, Ans As Variant

Application.ScreenUpdating = False
Sheets("Summary").Select
Rows("2:3000").ClearContents

Sheets("Details").Select
lastrow = Cells(3000, 1).End(xlUp).Row
Range(Cells(2, 5), Cells(lastrow, 5)).Select
Selection.FormulaR1C1 = "=DATEVALUE(MID(RC[-3],FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1)+1,FIND("","",RC[-3],FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1))-FIND("" "",RC[-3],FIND("" "",RC[-3])
+1+1)-1) & ""-"" & LEFT(MID(RC[-3],FIND("" "",RC[-3])+1,FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1)-FIND("" "",RC[-3])+1),3) & "" -"" &
MID(RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND("" "",RC[-3])+1+1))
+2,FIND("" "",RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND(""
"",RC[-3])+1+1))+2)-FIND("","",RC[-3],FIND("" "",RC[-3],FIND(""
"",RC[-3])+1+1))-2))+TIMEVALUE(MID(RC[-3],FIND(""
"",RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND("" "",RC[-3])+1+1))
+2)+1,15))"
Selection.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
Selection.Copy
Cells(2, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Selection.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("E:E").ClearContents

Sheets("Summary").Select
Range(Sheets("Details").Cells(3, 1), Sheets("Details").Cells(lastrow,
4)).Copy Cells(2, 1)


lastrow = Cells(3000, 1).End(xlUp).Row
Columns("A:E").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Key2:=Range("B2") _
, Order2:=xlDescending, Header:=xlYes, OrderCustom:=1,
MatchCase:= _
False, Orientation:=xlTopToBottom
Range(Cells(2, 5), Cells(lastrow, 5)).FormulaR1C1 =
"=IF(RC1<>R[-1]C1,""Y"",""N"")"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.Sort Key1:=Range("E2"), Order1:=xlDescending,
Key2:=Range("A2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1,
MatchCase:= _
False, Orientation:=xlTopToBottom

Ans = Application.CountIf(Columns("E"), "Y")
Rows(Ans + 2 & ":" & 3000).ClearContents
Columns("E").ClearContents
ActiveWindow.ScrollRow = 2
Cells(2, 1).Select
End Sub
Click to expand...
 
D

dzelnio

I get it. Thanks Trevor.

dzelnio

Can't test this properly because I don't know what the data looks like.

Try to avoid selecting cells wherever possible. For example:

Option Explicit
Sub Summary()
Dim lastrow As Long, path As String, today As Long, Ans As Variant

Application.ScreenUpdating = False
Sheets("Summary").Select
Rows("2:3000").ClearContents

Sheets("Details").Select
lastrow = Cells(3000, 1).End(xlUp).Row
With Range(Cells(2, 5), Cells(lastrow, 5))
.FormulaR1C1 = "=DATEVALUE(MID(RC[-3],FIND("""",RC[-3],FIND(""
"",RC[-3])+1+1)+1,FIND("","",RC[-3],FIND("""",RC[-3],FIND(""
"",RC[-3])+1+1))-FIND("" "",RC[-3],FIND("" "",RC[-3])+1+1)-1) & ""-"" &
LEFT(MID(RC[-3],FIND("" "",RC[-3])+1,FIND("""",RC[-3],FIND(""
"",RC[-3])+1+1)-FIND("" "",RC[-3])+1),3) & "" -"" &
MID(RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND(""
"",RC[-3])+1+1))+2,FIND("" "",RC[-3],FIND("","",RC[-3],FIND(""
"",RC[-3],FIND("""",RC[-3])+1+1))+2)-FIND("","",RC[-3],FIND(""
"",RC[-3],FIND("""",RC[-3])+1+1))-2))+TIMEVALUE(MID(RC[-3],FIND("""",RC[-3] ,FIND("","",RC[-3],FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1))+2)+1,15))"
.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
.Copy
End With
With Cells(2, 2)
.PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With
With Columns("B:B")
.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("E:E").ClearContents

Sheets("Summary").Select
Range(Sheets("Details").Cells(3, 1), Sheets("Details").Cells(lastrow,
4)).Copy Cells(2, 1)

lastrow = Cells(3000, 1).End(xlUp).Row
Columns("A:E").Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
With Range(Cells(2, 5), Cells(lastrow, 5))
.FormulaR1C1 = "=IF(RC1<>R[-1]C1,""Y"",""N"")"
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
.Sort Key1:=Range("E2"), Order1:=xlDescending, _
Key2:=Range("A2"), Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

Ans = Application.CountIf(Columns("E"), "Y")
Rows(Ans + 2 & ":" & 3000).ClearContents
Columns("E").ClearContents
ActiveWindow.ScrollRow = 2
Cells(2, 1).Select
End Sub

Regards

Trevor


The following script does some fairly simple stuff.
1. Find all unique records with the latest date (from Details)
2. Puts those records on Worksheet2 (aka Summary)
3. Converts dates from text to date form
Click to expand...
Can anyone see anything in here that would make it soooo slow?
Click to expand...
Option Explicit
Sub Summary()
Dim lastrow As Long, path As String, today As Long, Ans As Variant
Click to expand...
Application.ScreenUpdating = False
Sheets("Summary").Select
Rows("2:3000").ClearContents
Click to expand...
Sheets("Details").Select
lastrow = Cells(3000, 1).End(xlUp).Row
Range(Cells(2, 5), Cells(lastrow, 5)).Select
Selection.FormulaR1C1 = "=DATEVALUE(MID(RC[-3],FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1)+1,FIND("","",RC[-3],FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1))-FIND("" "",RC[-3],FIND("" "",RC[-3])
+1+1)-1) & ""-"" & LEFT(MID(RC[-3],FIND("" "",RC[-3])+1,FIND(""
"",RC[-3],FIND("" "",RC[-3])+1+1)-FIND("" "",RC[-3])+1),3) & "" -"" &
MID(RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND("" "",RC[-3])+1+1))
+2,FIND("" "",RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND(""
"",RC[-3])+1+1))+2)-FIND("","",RC[-3],FIND("" "",RC[-3],FIND(""
"",RC[-3])+1+1))-2))+TIMEVALUE(MID(RC[-3],FIND(""
"",RC[-3],FIND("","",RC[-3],FIND("" "",RC[-3],FIND("" "",RC[-3])+1+1))
+2)+1,15))"
Selection.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
Selection.Copy
Cells(2, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Selection.NumberFormat = "mm/dd/yy hh:mm:ss AM/PM"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("E:E").ClearContents
Click to expand...
Sheets("Summary").Select
Range(Sheets("Details").Cells(3, 1), Sheets("Details").Cells(lastrow,
4)).Copy Cells(2, 1)
Click to expand...
lastrow = Cells(3000, 1).End(xlUp).Row
Columns("A:E").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Key2:=Range("B2") _
, Order2:=xlDescending, Header:=xlYes, OrderCustom:=1,
MatchCase:= _
False, Orientation:=xlTopToBottom
Range(Cells(2, 5), Cells(lastrow, 5)).FormulaR1C1 =
"=IF(RC1<>R[-1]C1,""Y"",""N"")"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.Sort Key1:=Range("E2"), Order1:=xlDescending,
Key2:=Range("A2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1,
MatchCase:= _
False, Orientation:=xlTopToBottom
Click to expand...
Ans = Application.CountIf(Columns("E"), "Y")
Rows(Ans + 2 & ":" & 3000).ClearContents
Columns("E").ClearContents
ActiveWindow.ScrollRow = 2
Cells(2, 1).Select
End Sub
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Macro autofills formula when a cell value is changed 4
macro to copy rows that contain a cell with a certain number 2
VBA Compare part of cell to another cell and then calculate 0
Geometric progression in VBA 10
Linking Cells Macro 3
how do i separate addresses and place results in another cell 4
Display alert if data exists 2
Link Cells & Paste Special Macro 7

Top