Improve Performance of Insert

[fredlo2010]

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]

Have you turned off events?

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

[fredlo2010]

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]

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]

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]

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]

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]

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]

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.

ComparisonLogs.xlsx
https://dl.dropboxusercontent.com/u/...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]

[Blade Hunter]

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]

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.

image001.jpg

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

[SamT]

I got one more idea, just gotta find time. Hoping to break the 0.5 barrier

[snb]

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]

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]

That idea was slower than Blades. O well.

Not talking about paul's. My other idea.

[Paul_Hossler]

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]

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]

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]

@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