PDA

View Full Version : [SOLVED] Improve Performance of Insert



fredlo2010
01-08-2015, 01:30 PM
Hello,

I have sub that is use to format subtotals; but its not performing as fast as I would like to.

I have already set all my extra calculations and screen refreshes to off. I am almost sure the problem is the insertion of the rows.

Is there a way to improve this a little so far I am getting an average running time of about 3 seconds.

This is the code I have:



Sub FormatSubtotal(Optional ByVal strColumnLetter As String, _
Optional ByVal strKeyWord As String = "Total", _
Optional ByVal shToCheck As Worksheet)

Dim rToSearch As Range
Dim rFound As Range
Dim strFirstAddress As String


' Check the sheet if not the default.
If shToCheck Is Nothing Then Set shToCheck = ActiveSheet


' If there is no letter then search in the used range.
If strColumnLetter = vbNullString Then
Set rToSearch = shToCheck.UsedRange
Else
Set rToSearch = shToCheck.Columns(strColumnLetter)
End If

' Perform the actual search.
With rToSearch
Set rFound = .Find(What:=strKeyWord, Lookin:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True, _
Matchbyte:=False, SearchFormat:=False)

If Not rFound Is Nothing Then


strFirstAddress = rFound.Offset(1).Address


Do
'Make everything uppercase
With rFound.Resize(, shToCheck.UsedRange.Columns.Count)
.Font.Bold = True
.Insert Shift:=xlShiftDown
.Offset(1, 0).Insert
End With

Set rFound = .FindNext(rFound)

Loop While Not rFound Is Nothing And rFound.Address <> strFirstAddress
End If
End With


' Clean up
Set rFound = Nothing
Set rToSearch = Nothing
Set shToCheck = Nothing


End Sub


Any ideas?

Thanks a lot in advance. :)

Kenneth Hobs
01-10-2015, 08:23 PM
Have you turned off events?

http://vbaexpress.com/kb/getarticle.php?kb_id=1035

fredlo2010
01-11-2015, 08:29 AM
Have you turned off events?

http://vbaexpress.com/kb/getarticle.php?kb_id=1035

Thanks for the reply. Yes I have turned off events. There are property in the post you sent me I have never used.



.Cursor = xlWait
.EnableCancelKey = xlErrorHandler


I will do some reading about them

SamT
01-11-2015, 09:01 AM
Try and see

Sub FormatSubtotal(Optional ByVal strColumnLetter As String, _
Optional ByVal strKeyWord As String = "Total", _
Optional ByVal shToCheck As Worksheet)

Dim rToSearch As Range
Dim rFound As Range
Dim strFirstAddress As String

' Check the sheet if not the default.
If shToCheck Is Nothing Then Set shToCheck = ActiveSheet

' IF function not used. strColumnLetter is absolutely required above.
If strColumnLetter = vbNullString Then
Set rToSearch = shToCheck.UsedRange
'Use with caution if strKeyWord in multiple columns
Else
Set rToSearch = shToCheck.Columns(strColumnLetter)
End If

' Perform the actual search.
With rToSearch
Set rFound = .Find(What:=strKeyWord, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True, _
Matchbyte:=False, SearchFormat:=False)

If Not rFound Is Nothing Then
strFirstAddress = rFound.Offset(1).Address

Do
'ToDo: Make everything uppercase
With rFound.EntireRow
'EntireRow prevents partial shifts when
'strColumnLetter is not "A
.Font.Bold = True
.Insert
.Offset(1, 0).Insert
End With

Set rFound = .FindNext(rFound)

Loop While rFound.Address <> strFirstAddress
End If
End With


' Clean up
Set rFound = Nothing
Set rToSearch = Nothing
Set shToCheck = Nothing


End Sub

Note that if you make strColumnLetter optional and search UsedRange using LookAt:=xlPart, then this sub will insertrows at, for ex. "SubTotal," "Total," and GandTotal," even though they are in different columns.

I think this procedure is half User called and half Code called, without being best for either. If it is to called by Users, then it should only perform specific tasks without need of inputs. This means it needs a definitive name.

Sub FormatArtsDeptQuarterlyBudgetProposal()
Const strColumnLetter As String = "C"
Const strKeyWord As String = "Total"

With ActiveSheet

I think that you do have a good start on a multiuse Call-By-Code procedure, but never use optional parameters if it is called by another procedure. Make the coder, (You) specify what is to happen at every call.


Sub FormatAndSpaceRowsByKeyWord(ByRef wbToCheck As Excel.Workbook, _
ByRef shToCheck As Excel.Worksheet, _
ByRef rRngToCheck As Excel.Range, _
ByVal strKeyWord As String, _
ByVal SpaceAbove As Boolean)

Dim rFound As Range
Dim strFirstAddress As String

On Error GoTo ObjectIssues
'Uber simple test on all Objects at once.
With wbToCheck.shToCheck.rRngToCheck
Err.Clear
' Perform the actual search.
Set rFound = .Find(What:=strKeyWord, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)

If Not rFound Is Nothing Then
strFirstAddress = rFound.Offset(1).Address
Do
'ToDo: Make everything uppercase
'I would move the Uppercse function completely out of here
'the Replace function is very fast.
'Embolding is so common in these circumstances, that
'I would seriously consider using an Optional (Boolean=True)
'input Parameter for this choice.
With rFound.EntireRow
.Font.Bold = True
If SpaceAbove Then .Insert
.Offset(1, 0).Insert
End With

Set rFound = .FindNext(rFound)
Loop While rFound.Address <> strFirstAddress
End If
End With

GoTo GoodExit

ObjectIssues:
MsgBox "Could not find Sheet " & shToCheck.Name '& " etc
GoTo GoodExit

NextErrorHandler:
GoToGoodExit

GoodExit:
End Sub

fredlo2010
01-11-2015, 09:29 AM
Thanks for the input Sam.

I will have to test this tomorrow at work.

The procedure is code called at all times.

I tried using the .EntireColumn property before but it showed to be slower so I constricted it so the shrift and the emboldening was limited to the used range. Also the Make all Capital section is a vestigial comment from when it used to be here. Its been replaced by a Replace function (I left it out of the code to make it simpler) :)

I will change the byval parameter to byref and see if that will help.

BTW the procedure takes abut 3 seconds to complete and its called about 22 times when run full for a total of 66 seconds. This will only happen if the user decides to run all the reports which almost never happens; so they will only experience a big delay rarely.

Using Kenneth suggestion I will display a cursor for the waiting.

Thanks

SamT
01-11-2015, 11:11 AM
2 minutes? that would need to be many hundred loops. I remember doing something similar a couple of months back. IIRC about 100 rows of data. Sum an entire column. Insert, label and format rows. Loop thru, insert Rows and sums at some keywords creating Sections. Loop, insert, creat smaller sections and sum them. Repeat one more time with yet smaller sections. he wound up with thee levels + the grand total. all row insertions, text labels, formatting and totals and subtotals by code, using changes in various column values. That was three loops, once each for three columns, with 100 rows of data. It seemed at the time to take less than a second. I had to use 'For i = LastRow to 2 step - 1' loops at that.

How many rows are in these workbooks?


I tried using the .EntireColumn property EntireRow???

UsedRange, if inside the loop, gets reset every iteration. Remember that UsedRange is not a great indicator of the sheet's actual used range.

Try using SearchDirection:=xlPrevious, with a variable set to the Row number of FirstFound and After:=RngToCheck.Cells(1) then
Loop until rFound.Row > FirstFound.Row

Assuming that the actual UsedRange starts in Column ("A"), you can limit the acted on range by

LastCol = UsedRange.Columns.Count

Do '6 dots per loop
With Application.Rows(rFound.Row).Range(Cells(1), Cells(LastCol))
.Font'etc
.Insert'etc
Loop

You can pick up a little more speed with

Set rActionsRange = Range(Range("A1"), Cells(Rows.Count, UsedRange.Columns.Count))

Do '2 dots per loop
With rActionsRange.Rows(rFound.Row)
.Font'etc
.Insert'etc
Loop

SamT
01-11-2015, 12:50 PM
2 minutes? that would need to be many hundred loops. I remember doing something similar a couple of months back. IIRC about 100 rows of data. Sum an entire column. Insert, label and format rows. Loop thru, insert Rows and sums at some keywords creating Sections. Loop, insert, creat smaller sections and sum them. Repeat one more time with yet smaller sections. he wound up with thee levels + the grand total. all row insertions, text labels, formatting and totals and subtotals by code, using changes in various column values. That was three loops, once each for three columns, with 100 rows of data. It seemed at the time to take less than a second. I had to use 'For i = LastRow to 2 step - 1' loops at that.

How many rows are in these workbooks?


I tried using the .EntireColumn property EntireRow???

UsedRange, if inside the loop, gets reset every iteration. Remember that UsedRange is not a great indicator of the sheet's actual used range.

Try using SearchDirection:=xlPrevious, with a variable set to the Row number of FirstFound and After:=RngToCheck.Cells(1) then
Loop until rFound.Row > FirstFound.Row

Assuming that the actual UsedRange starts in Column ("A"), you can limit the acted on range by

LastCol = UsedRange.Columns.Count

Do '6 dots per loop
With Application.Rows(rFound.Row).Range(Cells(1), Cells(LastCol))
.Font'etc
.Insert'etc
Loop

You can pick up a little more speed with

Set rActionsRange = Range(Range("A1"), Cells(Rows.Count, UsedRange.Columns.Count))

Do '2 dots per loop
With rActionsRange.Rows(rFound.Row)
.Font'etc
.Insert'etc
Loop

SamT
01-11-2015, 01:10 PM
Sub FormatAndSpaceRowsByKeyWord(ByRef wbToCheck As Excel.Workbook, _
ByRef shToCheck As Excel.Worksheet, _
ByRef rRngToCheck As Excel.Range, _
ByVal strKeyWord As String, _
ByVal SpaceAbove As Boolean, _
Optional Embolden As Boolean = True, _
Optional SpaceBelow As Boolean = True)
'Finds Rows with strKeyWord in designated Column. Optionally makes
'Font Bold, or inserts empty Rows above or below Found Rows

Dim FoundRow As Long
Dim FirstFoundRow As Long
Dim ActionRange As Range


On Error GoTo ObjectIssues
'Uber simple test on all Objects at once.
With wbToCheck.shToCheck
Set ActionRange = Range(.Range("A1"), .Cells(Rows.Count, .UsedRange.Columns.Count))
With .rRngToCheck
Err.Clear
' Perform the actual search.
FoundRow = .Find(What:=strKeyWord, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=True, _
After:=.Cells(1) _
).Row

If FoundRow <> 0 Then
If SpaceAbove Then
FirstFoundRow = FoundRow
Else: FirstFoundRow = FoundRow - 1
End If
Do
With ActionRange.Rows(FoundRow)
If Embolden Then .Font.Bold = True
If SpaceAbove Then .Insert 'Might need Shift direction here
If SpaceBelow Then .Offset(1, 0).Insert 'and here
End With
FoundRow = .FindNext(strKeyWord).Row
LoopWhile FoundRow <= FirstFoundRow
End If
End With
End With

GoTo GoodExit

ObjectIssues:
MsgBox "Could not find Sheet " & shToCheck.Name '& " etc
GoTo GoodExit

NextErrorHandler:
GoToGoodExit

GoodExit:
End Sub

fredlo2010
01-11-2015, 01:10 PM
Excellent help Sam (always).

I could not help myself so I put together a sample of a workbook that would behave similar to mine. Now, I am not sure why my workbook at work runs so slow, maybe it has to do with the operating system, memory or network connection (we usually user rdp to work)

Either way, I followed your advise and the performance gain is about 40% :) I cannot be happier :)

This is the sample file I used and the log for the tests.

12700
https://dl.dropboxusercontent.com/u/30987064/Subtotals.xlsm

I had to use dropbox cuz the file is big.

This is the code:



Sub FormatSubtotalFixed(ByVal strColumnLetter As String, _
ByRef shToCheck As Worksheet, _
Optional ByVal strKeyWord As String = "Total")


Dim rToSearch As Range
Dim rFound As Range
Dim strFirstAddress As String
Dim lMaxCol As Long

' Determine the max column
lMaxCol = shToCheck.UsedRange.Columns.Count


' If there is no letter then search in the used range.
If strColumnLetter = vbNullString Then
Set rToSearch = shToCheck.UsedRange
Else
Set rToSearch = shToCheck.UsedRange.Columns(strColumnLetter)
End If


' Perform the actual search.
With rToSearch
Set rFound = .Find(What:=strKeyWord, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True, _
Matchbyte:=False, SearchFormat:=False)

If Not rFound Is Nothing Then


strFirstAddress = rFound.Offset(1).Address


Do
'Make everything uppercase
With rFound.EntireRow
.Font.Bold = True
.Insert Shift:=xlShiftDown
.Offset(1, 0).Insert
End With


Set rFound = .FindNext(rFound)


Loop While Not rFound Is Nothing And rFound.Address <> strFirstAddress
End If
End With

' Clean up
Set rFound = Nothing
Set rToSearch = Nothing


End Sub


Thanks a lot for the help gain Sam :)

SamT
01-11-2015, 01:47 PM
:beerchug:

Blade Hunter
01-12-2015, 09:53 PM
Late to the party but playing with the code you guys built together it seems like it is inserting whilst looping?

Is it not better to build a range (or as I chose a string) then do the manipulation all in one go?

Modified version of the code:



Sub FormatSubtotalFixed(ByVal strColumnLetter As String, _
ByRef shToCheck As Worksheet, _
Optional ByVal strKeyWord As String = "Total")
Dim rToSearch As Range
Dim rFound As Range
Dim strFirstAddress As String, InsertRange As String
Dim lMaxCol As Long

' Determine the max column
lMaxCol = shToCheck.UsedRange.Columns.Count


' If there is no letter then search in the used range.
If strColumnLetter = vbNullString Then
Set rToSearch = shToCheck.UsedRange
Else
Set rToSearch = shToCheck.UsedRange.Columns(strColumnLetter)
End If




' Perform the actual search.
With rToSearch
Set rFound = .Find(What:=strKeyWord, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True, _
Matchbyte:=False, SearchFormat:=False)

If Not rFound Is Nothing Then




strFirstAddress = rFound.Address




Do

If InsertRange = "" Then
InsertRange = rFound.Row & ":" & rFound.Row
Else
InsertRange = InsertRange & "," & rFound.Row & ":" & rFound.Row
End If




Set rFound = .FindNext(rFound)




Loop While Not rFound Is Nothing And rFound.Address <> strFirstAddress
'Make everything uppercase
With Range(InsertRange)
.Select
.Font.Bold = True
.Insert Shift:=xlShiftDown
.Offset(1, 0).Insert
End With
End If
End With

' Clean up
Set rFound = Nothing
Set rToSearch = Nothing




End Sub

fredlo2010
01-15-2015, 07:16 PM
Hi Blade,

Thanks for the answer. I am sorry I took a while to replay but Physics got my busy :)

I tried your code and it works perfectly (I modified it removing the .Select because it was not needed plus it was forcing me to select the sheets)

Your code was blazing fast as well.

12725

PS: Sam is still winning! (Sam you are the man!)
:) :) :)

SamT
01-15-2015, 11:25 PM
I got one more idea, just gotta find time. Hoping to break the 0.5 barrier :D

snb
01-16-2015, 07:53 AM
Sub M_snb()
With Sheet1.UsedRange.Columns(1)
.AutoFilter 1, "Total"
.Offset(1).SpecialCells(12).SpecialCells(2).Select
.AutoFilter
End With

Selection.EntireRow.Insert
End Sub

Paul_Hossler
01-17-2015, 12:13 PM
I was curious about a non-Find approach, so I stole snb's idea a little

Gotta admit I didn't follow all of the logic (for ex. comment says upper case, but didn't see that)

Also didn't have the monitoring code in the xlsm either, and only ran it on one sheet since my timings would not be a valid compare




Option Explicit
Sub drv()
Application.ScreenUpdating = False
Call FormatSubtotalFixed("A", Worksheets("Report1"), "Total")
Application.ScreenUpdating = True
MsgBox "done"

End Sub

Sub FormatSubtotalFixed(ByVal strColumnLetter As String, _
ByRef shToCheck As Worksheet, _
Optional ByVal strKeyWord As String = "Total")

Dim rToSearch As Range, rFound As Range, rCol As Range, rCell As Range


If Len(strColumnLetter) = 0 Then
Set rToSearch = shToCheck.UsedRange
Else
Set rToSearch = shToCheck.UsedRange.Columns(strColumnLetter)
End If

For Each rCol In rToSearch.Columns

Set rFound = Nothing
On Error Resume Next
Set rFound = rCol.SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo 0

If rFound Is Nothing Then GoTo NextCol

For Each rCell In rFound.Cells

If InStr(rCell.Value, strKeyWord) = 0 Then GoTo NextCell

rCell.Font.Bold = True

If Len(rCell.Offset(1, 0).Value) = 0 Then GoTo NextCol

rCell.EntireRow.Insert
rCell.Offset(1, 0).EntireRow.Insert
NextCell:
Next

NextCol:
Next
End Sub

SamT
01-17-2015, 03:54 PM
That idea was slower than Blades. O well.

Not talking about paul's. My other idea.

Paul_Hossler
01-17-2015, 06:52 PM
SamT -- If you have the timing subs and a benchmarking workbook, could you test the non-Find approach and compare it to the other approaches please?

I just wanted to know how not using Find compares

SamT
01-17-2015, 07:44 PM
Paul, I didn't save the book. I just used X = Now at the front and Y = Now at the end then ET = Y-X.

I do like Freds' work. He's quite the pro.

SamT
01-17-2015, 08:36 PM
Having now seen the example files it is really a narrowly specialised procedure. Your method is probably faster than all the others so far.

If I was designing one just for that workbook it would be


Sub DoubleSpaceNonEmptyRows(Sht As Object, ColumnLetter As String)
'Emboldens and Inserts entire Rows above and below every nonempty cell in Columns(ColumnLetter)
Dim Cel as range
Set Cel = Sht.Range(ColumnLetter & "1")

Do
Set Cel = Cel.End(xlDown)
If Cel.Row = Rows.Count Then Exit Sub
With Cel.EntireRow
.Bold = True
.Insert Shift:=xlShiftDown
.Offset(1)Insert
End With
Loop

End Sub


Sub Test_DoubleSpaceNonEmptyRows()
For i = m to n
DoubleSpaceTotalRows(sheets(i), "A")
Next
End Sub

On the idea that it does one thing on one type of sheet and it does it very well and very fast. It is so short and sweet that it is very easy to understand, and if it ever needs refactoring, that too is very easy.

Your version of Short and Sweet here might be a few millisecs faster or slower


Set ActionRange = Columns(i).SpecialCells(xlCellTypeConstants, xlTextValues).Offset(1) 'Skip header row
For each Cel in ActionRange
Embolden and insert
Next

snb
01-18-2015, 06:45 AM
@SamT

Did you incorporate my suggestion in your test ?
or this one:


Sub M_snb()
For Each sh In Sheets
If InStr(sh.Name, "Report") Then
With sh.UsedRange.Columns(1).Offset(1).SpecialCells(2, 2)
.Font.Bold = True
.EntireRow.Insert
End With
sh.UsedRange.Columns(1).Offset(1).SpecialCells(2, 2).Offset(1).EntireRow.Insert
End If
Next
End Sub

SamT
01-18-2015, 09:21 AM
Sorry, no. I only tested the one.

However, many days ago I did try


With RangeOfManyRows
.EntireRow.Insert
.Offset(1).Insert
End With
And got a weird result; extra rows. Your code is resetting the range, so I suspect it wouldn't do that. I have no doubt that M_snb is blindingly fast, that is a trademark of your programming.

I would recommend to Fred to take the sheet selection out of it after speed testing.

fredlo2010
01-25-2015, 01:20 AM
Hello everyone,

I am late but I did not get any of the notifications for this :)

So here we go. We have new people providing feedback and new code. So far the shortest code execution time that takes care of all the requirements; with a total of 0.48031 second goes to ... (drum roll) snb 2nd entry Post #20

:clap2::bigdance2:yay:clap2:


Here are the results


12754


Sam*: This one does not qualify because it does not insert the rows
snb*: This one does not qualify because it inserts only one row instead if 2

The links to the benchmark files and the code we have added can be fund here.
https://dl.dropboxusercontent.com/u/30987064/ComparisonLogs.xlsx
https://dl.dropboxusercontent.com/u/30987064/Subtotals.xlsm




SamT -- If you have the timing subs and a bench-marking workbook, could you test the non-Find approach and compare it to the other approaches please?

I just wanted to know how not using Find compares

Paul I am using the Perfmon tool that comes with this book http://www.amazon.com/Professional-Excel-Development-Definitive-Applications/dp/0321508793

Thanks a lot for all the help :)

snb
01-25-2015, 06:25 AM
This might be much faster:


Sub M_snb_003()
For Each sh In Sheets
If Left(sh.Name, 6) = "Report" Then
c00 = ""
sn = sh.UsedRange.Resize(sh.UsedRange.Rows.Count + 1)
For j = 1 To UBound(sn) - 1
If InStr(sn(j, 1), "Total") Then
c00 = c00 & " ~ " & j & " ~"
Else
c00 = c00 & " " & j
End If
Next

st = Application.Index(sn, Application.Transpose(Split(Trim(Replace(c00, "~", UBound(sn) & " " & UBound(sn))))), [transpose(row(1:26))])
sh.Cells(1).Resize(UBound(st), UBound(st, 2)) = st
End If
Next
End Sub

fredlo2010
01-25-2015, 12:04 PM
Hello,

@snb the last code was not as fast as the others and it did not produced the desired outcome. It gave me 2 empty rows above and bellow "Total" and it should have been one.

:)

snb
01-25-2015, 12:44 PM
That's an easy adaptation:


Sub M_snb_003()
For Each sh In Sheets
If Left(sh.Name, 6) = "Report" Then
c00 = ""
with sh.cells(1).currentregion
sn = .Resize(.Rows.Count + 1,26)
end with

For j = 1 To UBound(sn) - 1
If InStr(sn(j, 1), "Total") Then
c00 = c00 & " ~ " & j & " ~"
Else
c00 = c00 & " " & j
End If
Next

st = Application.Index(sn, Application.Transpose(Split(Trim(Replace(c00, "~", UBound(sn))))), [transpose(row(1:26))])
sh.Cells(1).Resize(UBound(st), UBound(st, 2)) = st
End If
Next
End Sub