This question already has answers here:
How to measure code execution time in VBScript or JavaScript?
(7 answers)
Closed 2 years ago.
I have a Vbscript which outputs the time taken for my anti-virus to update the signature version on a daily basis at 05:00 AM, before performing a scan. This is the script
Function TimeSpan(dt1, dt2)
If (isDate(dt1) And IsDate(dt2)) = false Then
TimeSpan = "00:00:00"
Exit Function
End If
seconds = Abs(DateDiff("S", dt1, dt2))
minutes = seconds \ 60
hours = minutes \ 60
minutes = minutes mod 60
seconds = seconds mod 60
if len(hours) = 1 then hours = "0" & hours
TimeSpan = hours & ":" & _
RIGHT("00" & minutes, 2) & ":" & _
RIGHT("00" & seconds, 2)
End Function
d1 = LAST_UPDATE
d2 = 22 Jul 20 05:00:00AM
d1 [ LAST_UPDATE ] is the time the update is completed, so what I need is the starting time. The script runs accurately as long as I incorporate the date and time in ' d2 ' [ as shown in the script ]. This means that to output the result on a daily basis, I have to open the vbscript and change the date to current date [ the time remains constant at 05:00:00 AM ]
The output result is given to me after 10 minutes.
I have tried using ' Now ()' but this output includes the time taken from the time the update is completed and the 10 minutes [ that has lapsed ] till the result is provided. This doesnot serve the purpose of this script.
What I am trying to get at is, is there a way which can be incorporated in the script itself,[ with another fuction or so ] which will change the date [ to tomorrow ] and the time [ the time remains constant at 05:00:00 AM ] incrementally after every 24 hours at 12:00:00 AM in the script itself keepiing it ready for the next day's operation without any user action of changing the date manually
I have tried all ways possible to resolve this but have failed. My efforts always culminate in ' Now() ' and the entire excercise is wasted.
Any help will be appreciated.This is the script
Rajdeep
If you simply want to measure the time it takes for the anti-virus update to run, you can use the Timer function like this:
Dim sngStart
Dim sngTimeSpan
sngStart = Timer
' Do work here
sngTimeSpan = Timer - sngStart
sngTimeSpan is a value in seconds.
You can do the same with the Now function:
Dim dStart
dStart = Now
' Do work here
seconds = Abs(DateDiff("S", dStart, Now))
Essentially you are calling Timer or Now twice and calculating the difference between the two, eliminating the need for the d2 variable.
Here's a complete example using a MsgBox to simulate some task being performed:
Dim sngStart
Dim sngEnd
Dim sngSecondsElapsed
Dim iSecondsElapsed
Dim dStart
' Grab system Timer and current time
sngStart = Timer
dStart = Now
' Simulating a delay here by displaying a message box
MsgBox "Click OK after a few moments"
' Calculate seconds elapsed
sngSecondsElapsed = Timer - sngStart
iSecondsElapsed = Abs(DateDiff("S", dStart, Now))
MsgBox "Seconds Elapsed:" & vbCrLf & "Timer method: " & FormatNumber(sngSecondsElapsed, 2) & vbCrLf & "Now method: " & iSecondsElapsed
I am trying to find a way to filter large data and remove rows in a worksheet, in less than one minute
The goal:
Find all records containing specific text in column 1, and delete the entire row
Keep all cell formatting (colors, font, borders, column widths) and formulas as they are
.
Test Data:
:
.
How the code works:
It starts by turning all Excel features Off
If the workbook is not empty and the text value to be removed exists in column 1
Copies the used range of column 1 to an array
Iterates over every value in array backwards
When it finds a match:
Appends the cell address to a tmp string in the format "A11,A275,A3900,..."
If the tmp variable length is close to 255 characters
Deletes rows using .Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUp
Resets tmp to empty and moves on to the next set of rows
At the end, it turns all Excel features back On
.
The main issue is the Delete operation, and total duration time should be under one minute. Any code-based solution is acceptable as long as it performs under 1 minute.
This narrows the scope to very few acceptable answers. The answers already provided are also very short and easy to implement. One performs the operation in about 30 seconds, so there is at least one answer that provides an acceptable solution, and other may find it useful as well
.
My main initial function:
Sub DeleteRowsWithValuesStrings()
Const MAX_SZ As Byte = 240
Dim i As Long, j As Long, t As Double, ws As Worksheet
Dim memArr As Variant, max As Long, tmp As String
Set ws = Worksheets(1)
max = GetMaxCell(ws.UsedRange).Row
FastWB True: t = Timer
With ws
If max > 1 Then
If IndexOfValInRowOrCol("Test String", , ws.UsedRange) > 0 Then
memArr = .Range(.Cells(1, 1), .Cells(max, 1)).Value2
For i = max To 1 Step -1
If memArr(i, 1) = "Test String" Then
tmp = tmp & "A" & i & ","
If Len(tmp) > MAX_SZ Then
.Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp
tmp = vbNullString
End If
End If
Next
If Len(tmp) > 0 Then
.Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp
End If
.Calculate
End If
End If
End With
FastWB False: InputBox "Duration: ", "Duration", Timer - t
End Sub
Helper functions (turn Excel features off and on):
Public Sub FastWB(Optional ByVal opt As Boolean = True)
With Application
.Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
.DisplayAlerts = Not opt
.DisplayStatusBar = Not opt
.EnableAnimations = Not opt
.EnableEvents = Not opt
.ScreenUpdating = Not opt
End With
FastWS , opt
End Sub
Public Sub FastWS(Optional ByVal ws As Worksheet = Nothing, _
Optional ByVal opt As Boolean = True)
If ws Is Nothing Then
For Each ws In Application.ActiveWorkbook.Sheets
EnableWS ws, opt
Next
Else
EnableWS ws, opt
End If
End Sub
Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean)
With ws
.DisplayPageBreaks = False
.EnableCalculation = Not opt
.EnableFormatConditionsCalculation = Not opt
.EnablePivotTable = Not opt
End With
End Sub
Finds last cell with data (thanks #ZygD - now I tested it in several scenarios):
Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
'Returns the last cell containing a value, or A1 if Worksheet is empty
Const NONEMPTY As String = "*"
Dim lRow As Range, lCol As Range
If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
If WorksheetFunction.CountA(rng) = 0 Then
Set GetMaxCell = rng.Parent.Cells(1, 1)
Else
With rng
Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows)
If Not lRow Is Nothing Then
Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns)
Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
End If
End With
End If
End Function
Returns the index of a match in the array, or 0 if a match is not found:
Public Function IndexOfValInRowOrCol( _
ByVal searchVal As String, _
Optional ByRef ws As Worksheet = Nothing, _
Optional ByRef rng As Range = Nothing, _
Optional ByRef vertical As Boolean = True, _
Optional ByRef rowOrColNum As Long = 1 _
) As Long
'Returns position in Row or Column, or 0 if no matches found
Dim usedRng As Range, result As Variant, searchRow As Long, searchCol As Long
result = CVErr(9999) '- generate custom error
Set usedRng = GetUsedRng(ws, rng)
If Not usedRng Is Nothing Then
If rowOrColNum < 1 Then rowOrColNum = 1
With Application
If vertical Then
result = .Match(searchVal, rng.Columns(rowOrColNum), 0)
Else
result = .Match(searchVal, rng.Rows(rowOrColNum), 0)
End If
End With
End If
If IsError(result) Then IndexOfValInRowOrCol = 0 Else IndexOfValInRowOrCol = result
End Function
.
Update:
Tested 6 solutions (3 tests each): Excel Hero's solution is the fastest so far (removes formulas)
.
Here are the results, fastest to the slowest:
.
Test 1. Total of 100,000 records, 10,000 to be deleted:
1. ExcelHero() - 1.5 seconds
2. DeleteRowsWithValuesNewSheet() - 2.4 seconds
3. DeleteRowsWithValuesStrings() - 2.45 minutes
4. DeleteRowsWithValuesArray() - 2.45 minutes
5. QuickAndEasy() - 3.25 minutes
6. DeleteRowsWithValuesUnion() - Stopped after 5 minutes
.
Test 2. Total of 1 million records, 100,000 to be deleted:
1. ExcelHero() - 16 seconds (average)
2. DeleteRowsWithValuesNewSheet() - 33 seconds (average)
3. DeleteRowsWithValuesStrings() - 4 hrs 38 min (16701.375 sec)
4. DeleteRowsWithValuesArray() - 4 hrs 37 min (16626.3051757813 sec)
5. QuickAndEasy() - 5 hrs 40 min (20434.2104492188 sec)
6. DeleteRowsWithValuesUnion() - N/A
.
Notes:
ExcelHero method: easy to implement, reliable, extremely fast, but removes formulas
NewSheet method: easy to implement, reliable, and meets the target
Strings method: more effort to implement, reliable, but doesn't meet requirement
Array method: similar to Strings, but ReDims an array (faster version of Union)
QuickAndEasy: easy to implement (short, reliable and elegant), but doesn't meet requirement
Range Union: implementation complexity similar to 2 and 3, but too slow
I also made the test data more realistic by introducing unusual values:
empty cells, ranges, rows, and columns
special characters, like =[`~!##$%^&*()_-+{}[]\|;:'",.<>/?, separate and multiple combinations
blank spaces, tabs, empty formulas, border, font, and other cell formatting
large and small numbers with decimals (=12.9999999999999 + 0.00000000000000001)
hyperlinks, conditional formatting rules
empty formatting inside and outside data ranges
anything else that might cause data issues
I'm providing the first answer as a reference
Others may find it useful, if there are no other options available
Fastest way to achieve the result is not to use the Delete operation
Out of 1 million records it removes 100,000 rows in an average of 33 seconds
.
Sub DeleteRowsWithValuesNewSheet() '100K records 10K to delete
'Test 1: 2.40234375 sec
'Test 2: 2.41796875 sec
'Test 3: 2.40234375 sec
'1M records 100K to delete
'Test 1: 32.9140625 sec
'Test 2: 33.1484375 sec
'Test 3: 32.90625 sec
Dim oldWs As Worksheet, newWs As Worksheet, rowHeights() As Long
Dim wsName As String, t As Double, oldUsedRng As Range
FastWB True: t = Timer
Set oldWs = Worksheets(1)
wsName = oldWs.Name
Set oldUsedRng = oldWs.Range("A1", GetMaxCell(oldWs.UsedRange))
If oldUsedRng.Rows.Count > 1 Then 'If sheet is not empty
Set newWs = Sheets.Add(After:=oldWs) 'Add new sheet
With oldUsedRng
.AutoFilter Field:=1, Criteria1:="<>Test String"
.Copy 'Copy visible data
End With
With newWs.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll 'Paste data on new sheet
.Cells(1, 1).Select 'Deselect paste area
.Cells(1, 1).Copy 'Clear Clipboard
End With
oldWs.Delete 'Delete old sheet
newWs.Name = wsName
End If
FastWB False: InputBox "Duration: ", "Duration", Timer - t
End Sub
.
At high level:
It creates a new worksheet, and keeps a reference to the initial sheet
AutoFilters column 1 on the searched text: .AutoFilter Field:=1, Criteria1:="<>Test String"
Copies all (visible) data from initial sheet
Pastes column widths, formats, and data to the new sheet
Deletes initial sheet
Renames the new sheet to the old sheet name
It uses the same helper functions posted in the question
The 99% of the duration is used by the AutoFilter
.
There are a couple limitations I found so far, the first can be addressed:
If there are any hidden rows on the initial sheet, it unhides them
A separate function is needed to hide them back
Depending on implementation, it might significantly increase duration
VBA related:
It changes the Code Name of the sheet; other VBA referring to Sheet1 will be broken (if any)
It deletes all VBA code associated with the initial sheet (if any)
.
A few notes about using large files like this:
The binary format (.xlsb) reduce file size dramatically (from 137 Mb to 43 Mb)
Unmanaged Conditional Formatting rules can cause exponential performance issues
The same for Comments, and Data validation
Reading file or data from network is much slower than working with a locall file
A significant gain in speed can be achieved if the source data do not contain formulas, or if the scenario would allow (or want) the formulas to be converted into hard values during the conditional row deletions.
With the above as a caveat, my solution uses the AdvancedFilter of the range object. It's about twice as fast as DeleteRowsWithValuesNewSheet().
Public Sub ExcelHero()
Dim t#, crit As Range, data As Range, ws As Worksheet
Dim r&, fc As Range, lc As Range, fr1 As Range, fr2 As Range
FastWB True
t = Timer
Set fc = ActiveSheet.UsedRange.Item(1)
Set lc = GetMaxCell
Set data = ActiveSheet.Range(fc, lc)
Set ws = Sheets.Add
With data
Set fr1 = data.Worksheet.Range(fc, fc.Offset(, lc.Column))
Set fr2 = ws.Range(ws.Cells(fc.Row, fc.Column), ws.Cells(fc.Row, lc.Column))
With fr2
fr1.Copy
.PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAll
.Item(1).Select
End With
Set crit = .Resize(2, 1).Offset(, lc.Column + 1)
crit = [{"Column 1";"<>Test String"}]
.AdvancedFilter xlFilterCopy, crit, fr2
.Worksheet.Delete
End With
FastWB False
r = ws.UsedRange.Rows.Count
Debug.Print "Rows: " & r & ", Duration: " & Timer - t & " seconds"
End Sub
On my elderly Dell Inspiron 1564 (Win 7 Office 2007) this:
Sub QuickAndEasy()
Dim rng As Range
Set rng = Range("AA2:AA1000001")
Range("AB1") = Now
Application.ScreenUpdating = False
With rng
.Formula = "=If(A2=""Test String"",0/0,A2)"
.Cells.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
.Clear
End With
Application.ScreenUpdating = True
Range("AC1") = Now
End Sub
took about 10 seconds to run. I am assuming that column AA is available.
EDIT#1:
Please note that this code does not set Calculation to Manual. Performance will improve if the Calculation mode is set to Manual after the "helper" column is allowed to calculate.
I know I'm incredibly late with my answer here however future visitors may find it very useful.
Please Note: My approach requires an index column for the rows to end up in the original order, however if you do not mind the rows being in a different order then an index column isn't needed and the additional line of code can be removed.
My approach: My approach was to simply select all the rows in the selected range (column), sort them in ascending order using Range.Sort and then collecting the first and last index of "Test String" within the selected range (column). I then create a range from the first and last indices and use Range.EntrieRow.Delete to remove all the rows which contain "Test String".
Pros:
- It is blazing fast.
- It doesn't remove formatting, formulas, charts, pictures or anything like the method which copies to a new sheet.
Cons:
- A decent size of code to implement however it is all straight-forward.
Test Range Generation Sub:
Sub DevelopTest()
Dim index As Long
FastWB True
ActiveSheet.UsedRange.Clear
For index = 1 To 1000000 '1 million test
ActiveSheet.Cells(index, 1).Value = index
If (index Mod 10) = 0 Then
ActiveSheet.Cells(index, 2).Value = "Test String"
Else
ActiveSheet.Cells(index, 2).Value = "Blah Blah Blah"
End If
Next index
Application.StatusBar = ""
FastWB False
End Sub
Filter And Delete Rows Sub:
Sub DeleteRowFast()
Dim curWorksheet As Worksheet 'Current worksheet vairable
Dim rangeSelection As Range 'Selected range
Dim startBadVals As Long 'Start of the unwanted values
Dim endBadVals As Long 'End of the unwanted values
Dim strtTime As Double 'Timer variable
Dim lastRow As Long 'Last Row variable
Dim lastColumn As Long 'Last column variable
Dim indexCell As Range 'Index range start
Dim sortRange As Range 'The range which the sort is applied to
Dim currRow As Range 'Current Row index for the for loop
Dim cell As Range 'Current cell for use in the for loop
On Error GoTo Err
Set rangeSelection = Application.InputBox("Select the (N=) range to be checked", "Get Range", Type:=8) 'Get the desired range from the user
Err.Clear
M1 = MsgBox("This is recommended for large files (50,000 or more entries)", vbYesNo, "Enable Fast Workbook?") 'Prompt the user with an option to enable Fast Workbook, roughly 150% performace gains... Recommended for incredibly large files
Select Case M1
Case vbYes
FastWB True 'Enable fast workbook
Case vbNo
FastWB False 'Disable fast workbook
End Select
strtTime = Timer 'Begin the timer
Set curWorksheet = ActiveSheet
lastRow = CLng(rangeSelection.SpecialCells(xlCellTypeLastCell).Row)
lastColumn = curWorksheet.Cells(1, 16384).End(xlToLeft).Column
Set indexCell = curWorksheet.Cells(1, 1)
On Error Resume Next
If rangeSelection.Rows.Count > 1 Then 'Check if there is anything to do
lastVisRow = rangeSelection.Rows.Count
Set sortRange = curWorksheet.Range(indexCell, curWorksheet.Cells(curWorksheet.Rows(lastRow).Row, 16384).End(xlToLeft)) 'Set the sort range
sortRange.Sort Key1:=rangeSelection.Cells(1, 1), Order1:=xlAscending, Header:=xlNo 'Sort by values, lowest to highest
startBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, MatchCase:=False).Row
endBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False).Row
curWorksheet.Range(curWorksheet.Rows(startBadVals), curWorksheet.Rows(endBadVals)).EntireRow.Delete 'Delete uneeded rows, deleteing in continuous range blocks is quick than seperated or individual deletions.
sortRange.Sort Key1:=indexCell, Order1:=xlAscending, Header:=xlNo 'Sort by index instead of values, lowest to highest
End If
Application.StatusBar = "" 'Reset the status bar
FastWB False 'Disable fast workbook
MsgBox CStr(Round(Timer - strtTime, 2)) & "s" 'Display duration of task
Err:
Exit Sub
End Sub
THIS CODE USES FastWB, FastWS AND EnableWS BY Paul Bica!
Times at 100K entries (10k to be removed, FastWB True):
1. 0.2 seconds.
2. 0.2 seconds.
3. 0.21 seconds.
Avg. 0.2 seconds.
Times at 1 million entries (100k to be removed, FastWB True):
1. 2.3 seconds.
2. 2.32 seconds.
3. 2.3 seconds.
Avg. 2.31 seconds.
Running on: Windows 10, iMac i3 11,2 (From 2010)
EDIT
This code was originally designed with the purpose of filtering out numeric values outside of a numeric range and has been adapted to filter out "Test String" so some of the code may be redundant.
Your use of arrays in calculating the used range and row count may effect the performance. Here's another approach which in testing proves efficient across 1m+ rows of data - between 25-30 seconds. It doesn't use filters so will delete rows even if hidden. Deleting a whole row won't effect formatting or column widths of the other remaining rows.
First, check if the ActiveSheet has "Test String". Since you're only interested in Column 1 I used this:
TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
If TCount > 0 Then
Instead of using your GetMaxCell() function I simply used Cells.SpecialCells(xlCellTypeLastCell).Row to get the last row:
EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
Then loop through the rows of data:
While r <= EndRow
To test if the cell in Column 1 is equal to "Test String":
If sht.Cells(r, 1).Text) = "Test String" Then
To delete the row:
Rows(r).Delete Shift:=xlUp
Putting it all together full code below. I've set ActiveSheet to a variable Sht and added turned of ScreenUpdating to improve efficiency. Since it's a lot of data I make sure to clear variables at the end.
Sub RowDeleter()
Dim sht As Worksheet
Dim r As Long
Dim EndRow As Long
Dim TCount As Long
Dim s As Date
Dim e As Date
Application.ScreenUpdating = True
r = 2 'Initialise row number
s = Now 'Start Time
Set sht = ActiveSheet
EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
'Check if "Test String" is found in Column 1
TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
If TCount > 0 Then
'loop through to the End row
While r <= EndRow
If InStr(sht.Cells(r, 1).Text, "Test String") > 0 Then
sht.Rows(r).Delete Shift:=xlUp
r = r - 1
End If
r = r + 1
Wend
End If
e = Now 'End Time
D = (Hour(e) * 360 + Minute(e) * 60 + Second(e)) - (Hour(s) * 360 + Minute(s) * 60 + Second(s))
Application.ScreenUpdating = True
DurationTime = TimeSerial(0, 0, D)
MsgBox Format(DurationTime, "hh:mm:ss")
End Sub
I have 2 workbooks that contain the same macro. In one workbook the macro runs super fast, less than a second. In the other it takes almost 30 seconds to run. I'm using Excel 2003. The page breaks are off in both workbooks. I don't know what could be causing one to run slower than the other. Any ideas?
Sub viewFirst()
Dim dataSheet As Worksheet, inputSheet As Worksheet, projectID As Long
Dim projectRow As Long, lLastRec As Long, inputLastRow As Long, dataLastRow As Long, x As Long, sh As Shape
Worksheets("Input").Select
ActiveSheet.Protect "", UserInterfaceOnly:=True
Range("a1").Select
ActiveSheet.Pictures.Insert ("working.jpg")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set inputSheet = Worksheets("Input")
Set dataSheet = Worksheets("Database")
With inputSheet
inputLastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
End With
With dataSheet
dataLastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
lLastRec = dataLastRow - 1
End With
With inputSheet
.Range("currentProject").Value = 1
projectID = .Range("currentProject").Value
projectRow = projectID + 1
For x = 1 To inputLastRow
If Range("b" & x).HasFormula Then
x = x + 1
End If
If x > inputLastRow Then
Exit For
End If
If Not Range("b" & x).HasFormula Then
.Range("b" & x).Value = dataSheet.Cells(projectRow, 2 + x)
End If
Next x
.Range("d125").Value = dataSheet.Cells(projectRow, 2 + 149)
.Range("d128").Value = dataSheet.Cells(projectRow, 2 + 150)
.Range("d131").Value = dataSheet.Cells(projectRow, 2 + 151)
.Range("d134").Value = dataSheet.Cells(projectRow, 2 + 152)
.Range("d137").Value = dataSheet.Cells(projectRow, 2 + 153)
.Range("d140").Value = dataSheet.Cells(projectRow, 2 + 154)
End With
With ActiveSheet
For Each sh In .Shapes
If sh.Type = msoPicture Then
ActiveSheet.Unprotect ""
sh.Delete
ActiveSheet.Protect "", UserInterfaceOnly:=True
End If
Next sh
End With
Range("b5").Select
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
-EDIT-
osknows, thanks for the response. Just to clarify, the workbooks are never open at the same time, and again the workbooks are identical except for the data on the dataSheet - the dataSheet where the macro runs slowly has 35 Rows x 204 Columns, the dataSheet that runs quickly has 56 Rows X 156 Columns. I am going to search for hidden columns or non-blank cells on the input sheet.
Without seeing the 2 workbooks it's difficult to tell. The best advice is to measure exactly the speed of your code by...
In a module decare
Public Declare Function GetTickCount Lib "kernel32" () As Long
then in your code between certain lines of code place
dtStart = GetTickCount
dtline2 = GetTickCount
dtline3 = GetTickCount
dtline4 = GetTickCount
..
etc
the number of ticks between dtStart and dtline2 equals dtline2 - stStart etc
Also a number of factors that could slow things down:
inputLastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
could include many rows that seem blank but aren't.
Set inputSheet = Worksheets("Input") & Set dataSheet = Worksheets("Database") may be massive complex ranges
For Each sh In .Shapes could include many duplicate shapes over each other that look identical
You have undefined ranges & sheets that if you have multiple workbooks open and using them while code runs then workbooks/worksheets/ranges are not explicitly defined. (Eg .Range versus Range) Get into the habit of using the full path to a range Filepath/Workbook/Sheet/Range or cell etc using With statements
eg
With ThisWorkbook
With SheetXYZ
With .range("XYZ1")
End with
End With
End With
or
With ThisWorkbook
With SheetXYZ.range("XYZ1")
.formula = "=Now()"
End With
End With
Also check out this handy site Excel Pages
On the slower machine, unload any Add-ins. If you have an add-in with a global change event, that will fire every time any worksheet changes, and could be causing the slow down. You're writing to the spreadsheet quite a bit, so it would be called a lot.
Instead of writing cell-by-cell, consider building an array (2-dimensions, lower bound of 1) and write all the data to the cell in one big swoop. Here's an example of how that works
Sub WriteOnce()
Dim aReturn() As Double
Dim i As Long, j As Long
Const lLASTROW As Long = 10
Const lLASTCOL As Long = 5
ReDim aReturn(1 To lLASTROW, 1 To lLASTCOL)
For i = 1 To lLASTROW
For j = 1 To lLASTCOL
aReturn(i, j) = Rnd
Next j
Next i
Sheet1.Range("A1").Resize(UBound(aReturn, 1), UBound(aReturn, 2)).Value = aReturn
End Sub
Since I'm only accessing the worksheet once, any event handlers will only fire once.