Speed up a macro

Attached is a workbook that takes an imported text file, inserts rows with text.
It is SLOW, you can watch each line being inserted with the text, I would think with such a small sample dataset it would be much much quicker.

Information: See attached xls file.
On sheet1 is the imported data, sheet2 is a copy of the imported data so one can copy and paste to sheet1 as needed with out re-importing for test purposes and only for this query. (Sheets2 thru 3 are not used otherwise).

There is a command button on sheet one which will run macro "aaa". If you run this you will see how slow it is and exactly what it is doing.

I am simply looking for a way to speed this up, I have some files that are 10 times the size of the sample data and they take 10 or more minutes to run.

Be aware! I am not a professional VBA programmer, but I did stay at a Holiday Inn once.

Any hints, tips or examples are welcome.

Edit: It appears I did not link the commandbutton to macro "aaa", please run macro "aaa" manually instead.

You've commented out the piece of code at the start that turns screen updating off. This can make a big difference speed wise when running code as Excel is not having to redraw the screen all the time.

Dom

I did that on purpose and it doesn't help at all.

Thank you for looking.

p.s.
I borrowed your sig

I'm surprised it makes no difference. I'm leaving the office now but will have a look at the rest of your code later if I can drag myself away from the pub.

Dom

Originally Posted by Rick_Stanich

I did that [commented out ScreenUpdating = False] on purpose and it doesn't help at all.

Rick, disabling repaint always makes a difference... the very reason you can "see the rows being inserted" is because it is enabled to start with.

Insertion / Removal of rows is Volatile action and triggers events / calculation etc ... on that basis it's always a good idea to toggle these settings also, eg:

Sub aaa()
Dim xlCalc As XlCalculation
Dim othervariables...

On Error GoTo ExitPoint

With Application
    xlCalc = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With

'main code....

ExitPoint:
With Application
    .Calculation = xlCalc
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

I will let Dom go through the code once he's had a few jars but the above would be my quick 2cents...

(EDIT: having just had a gander - avoid Selecting objects - this will slow your code also...see: http://blogs.msdn.com/excel/archive/...practices.aspx)

Damn brilliant!
Simply removing ".EntireRow.Select" made a significant difference in speed. Significant indeed.
I will also use your snippets of code in my projects.

Domski, Donkeyote
Thanks!

Edit:
Went from 17 seconds to a few seconds for this sample dataset!

hi,

Edit: I should refresh my screen more regularly before posting!
Anyway, even though DO's beaten me to the punch, & you've got an initial improvement, I'll see if I can do even more shortly...
/end edit

I'm as surprised as Dom that turning off the screen updating makes no difference?
Anyway, to save Dom tearing himself away from the pub...

My first thought was that you could probably get a reasonable speed improvement if you change to using a variant array approach to take the data into memory, work through it, make any changes, then write back to the sheet (here's an example: http://www.excelforum.com/2229367-post4.html). BUT, from glancing at your code, I see that you are inserting rows if some conditions are met - these mean I need to think about how to implement a variant array approach... which I am now, I'll repost if I can make something work.

With your code as it currently is I suggest:
- changing all ".value" sections to ".value2" (see http://www.decisionmodels.com/Calcse...tm#performance)
- change code to prevent activation/selection where possible eg

                Cells(LRow, "A").Activate
                'MsgBox Cells(lRow, "A").Value 'for testing
                With Selection
                    If .Value <> "SNSLCT/S(S1)" Then
                        .EntireRow.Select
                        .Insert Shift:=xlDown
                    End If
                End With
'I think (untested!) can be changed to...
                    With Cells(LRow, "A")
                        If .Value <> "SNSLCT/S(S1)" Then
                            .EntireRow.Insert Shift:=xlDown
                        End If
                    End With

- perhaps use a select case rather than multiple If statements for the testing
- can the loops (or at least 2 of them) be merged?
- Could you use the autofilter & SpecialCells(xlCellTypeVisible) to remove the need for looping?
(try recording a macro of your actions & then modifying it for the different strings)

hth
Rob

broro183
I will give your suggestions/examples a try.
Thanks for the info!!

All but one area could be worked out via your example.

Sub aaa()
'JumpTo label naming by calibration name and data entry to excel PPG file
'Add Calibration label name for Jumpto Name. Example: (CAL_1) or (QUA_1), _
  etc. except do not use (QUA_1a).

'Application.ScreenUpdating = False

'sample search string. MEAS/SPHERE,F(QUA_1),5
For lRow = Range("A1").End(xlDown).Row To 2 Step -1
    If Left(Cells(lRow, "A").Value, 13) = "MEAS/SPHERE,F" Then
        'If Cells(lRow, "A").Offset(-1, 0).Value <> "RECALL/D(COORD1),DISK" Then
        Cells(lRow, "A").Activate
        With Selection
            'MsgBox Cells(lRow, "A").Value    'for testing
            'find left "(" and then right ")" string example: "(CAL_1)"
            sCalName = Cells(lRow, "A").Value
            sCalName = Mid(sCalName, InStr(.Value, "("), InStr(sCalName, ")") - _
                    InStr(sCalName, "(") + 1)
        End With
        'MsgBox sCalName & " " & Cells(lRow, "A").Address    'for testing
        'End If
    End If

    'Add calibration label name. example: (QUA_1)
    If sCalName <> "(QUA_1)" Then
        If Left(Cells(lRow, "A").Value, 8) = "SNSLCT/S" Then
            With Cells(lRow, "A")
                If .Value <> "SNSLCT/S(S1)" Then
                    .Insert Shift:=xlDown
                End If
            End With

            If Cells(lRow, "A").Offset(-1, 0).Value <> _
                    "RECALL/D(COORD1),DISK" Then
                'MsgBox Cells(lRow, "A").Value
                If Cells(lRow, "A").Value = "SNSLCT/S(S1)" Then
                    Cells(lRow, "A").Value = sCalName
                Else
                    Cells(lRow, "A").Value = sCalName
                    'MsgBox Cells(lRow, "A").Address
                End If
                'MsgBox Cells(lRow, "A").Address
            End If
        End If
    End If    '12.28.09
Next lRow
Range("A1").Activate

'Add "RECALL/D(COORD1),DISK" after new Jumpto label name
'sample search string. MEAS/SPHERE,F(QUA_1),5
For lRow = Range("A1").End(xlDown).Row To 2 Step -1
    If Left(Cells(lRow, "A").Value, 13) = "MEAS/SPHERE,F" Then
        If Cells(lRow, "A").Offset(-1, 0).Value <> "RECALL/D(COORD1),DISK" Then
            With Cells(lRow, "A")
                'MsgBox Cells(lRow, "A").Value    'for testing
                'find left "(" and then right ")" string example: "(CAL_1)"
                sCalName = Cells(lRow, "A").Value
                sCalName = Mid(sCalName, InStr(.Value, "("), InStr(sCalName, ")") - InStr(sCalName, "(") + 1)
                If sCalName <> "(QUA_1a)" Then
                    'MsgBox sCalName    'for testing
                End If
            End With
        End If
    End If
    'MsgBox Cells(lRow, "A").Value & " " & sCalName    'for testing

    If Left(Cells(lRow, "A").Value, 8) = "SNSLCT/S" Then
        'MsgBox "a"    'for testing
        If Cells(lRow, "A").Offset(-1, 0).Value = sCalName Then
            'MsgBox "b"    'for testing
            If Cells(lRow, "A").Offset(-1, 0).Value <> "(QUA_1)" Then
                'MsgBox "c"    'for testing
                With Cells(lRow, "A")
                    .Insert Shift:=xlDown
                End With
                Cells(lRow, "A").Value = "RECALL/D(COORD1),DISK"
            End If
        End If
    End If
    'MsgBox Cells(lRow, "A").Value    'for testing
Next lRow

For lRow = Range("A1").End(xlDown).Row To 2 Step -1
    If Cells(lRow, "A").Value = "MEAS/SPHERE,F(QUA_1),5" Then
        If Right(Cells(lRow, "A").Offset(-3, 0).Value, 7) <> "-0.4999" Then
            Cells(lRow, "A").Offset(-2, 0).EntireRow.Activate
            With Selection
                .Insert Shift:=xlDown
                ActiveCell.Value = "(QUA_1)"
            End With        End If
    End If
Next lRow
Range("A1").Activate
Application.ScreenUpdating = True
End Sub

I tried a couple variants of your example which would not place the text "(QUA_1)", it would insert the new row, just no text.

            With  Cells(lRow, "A").Offset(-2, 0).EntireRow.Activate
                .Insert Shift:=xlDown
                ActiveCell.Value = "(QUA_1)"
            End With

and

            With Cells(lRow, "A")
                .Offset(-2, 0).Insert Shift:=xlDown
                ActiveCell.Value = "(QUA_1)"
            End With

With the new changes, the code is even quicker!

hi Rick,

Yes, I had a few problems too - I haven't merged any of the loops yet but this seems to work so far...
- I may have gone slightly overboard with my use of With statements as well ;-)

Option Explicit

Sub Modified_aaa_v2()
'JumpTo label naming by calibration name and data entry to excel PPG file
'Add Calibration label name for Jumpto Name. Example: (CAL_1) or (QUA_1), _
  etc. except do not use (QUA_1a).
Dim xlCalc As XlCalculation
Dim RwIndex As Long
Dim LRow As Long
Dim sCalName As String
Dim ShtToChange As Worksheet
Dim RwOffset As Long
    With Application
        xlCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    On Error GoTo ExitPoint
    Set ShtToChange = ThisWorkbook.Worksheets("Sheet1")
    With ShtToChange
        LRow = .Range("A1").End(xlDown).Row
        'sample search string. MEAS/SPHERE,F(QUA_1),5
        For RwIndex = LRow To 2 Step -1
            RwOffset = 0
            With .Cells(RwIndex, "A")
                If Left(.Value2, 13) = "MEAS/SPHERE,F" Then
                    'find left "(" and then right ")" string example: "(CAL_1)"
                    sCalName = Mid(.Value2, InStr(.Value2, "("), InStr(.Value2, ")") - InStr(.Value2, "(") + 1)
                End If
                'Add calibration label name. example: (QUA_1)
                If sCalName <> "(QUA_1)" Then
                    If Left(.Value2, 8) = "SNSLCT/S" Then
                        If .Value2 <> "SNSLCT/S(S1)" Then
                            .EntireRow.Insert Shift:=xlDown
                            RwOffset = -1
                        End If
                        With .Offset(RwOffset, 0)
                            If .Offset(-1, 0).Value2 <> "RECALL/D(COORD1),DISK" Then
                                .Value2 = sCalName
                            Else
                                Stop
                            End If
                        End With
                    End If
                End If
            End With
        Next RwIndex
        'Add "RECALL/D(COORD1),DISK" after new Jumpto label name
        'sample search string. MEAS/SPHERE,F(QUA_1),5
        LRow = .Range("A1").End(xlDown).Row
        For RwIndex = LRow To 2 Step -1
            RwOffset = 0
            With .Cells(RwIndex, "A")
                Select Case True
                    Case Left(.Value2, 13) = "MEAS/SPHERE,F"
                        If .Offset(-1, 0).Value2 <> "RECALL/D(COORD1),DISK" Then
                            'find left "(" and then right ")" string example: "(CAL_1)"
                            sCalName = Mid(.Value2, InStr(.Value2, "("), InStr(.Value2, ")") - InStr(.Value2, "(") + 1)
                        End If
                    Case Left(.Value2, 8) = "SNSLCT/S"
                        With .Offset(-1, 0)
                            If .Value2 = sCalName Then
                                If .Value2 <> "(QUA_1)" Then
                                    .Offset(1, 0).EntireRow.Insert Shift:=xlDown
'                                    RwOffset = -1
                                   .Offset(1, 0).Value2 = "RECALL/D(COORD1),DISK"
                                Else
                                    Stop
                                End If
                            End If
                        End With
                    Case Else
                        'do nothing
                End Select
            End With
        Next RwIndex

        'Re-run loop for (QUA_1) label
        LRow = .Range("A1").End(xlDown).Row
        For RwIndex = LRow To 2 Step -1
            RwOffset = 0
            With .Cells(RwIndex, "A")
                If .Value2 = "MEAS/SPHERE,F(QUA_1),5" Then
                    With .Offset(-2, 0)
                        If Right(.Offset(-1, 0).Value2, 7) <> "-0.4999" Then
                            .EntireRow.Insert Shift:=xlDown
                            RwOffset = -1
                            .Offset(RwOffset, 0).Value2 = "(QUA_1)"
                        End If
                    End With
                End If
            End With
        Next RwIndex
        .Range("A1").Activate
    End With
ExitPoint:
    With Application
        .Calculation = xlCalc
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    Set ShtToChange = Nothing
    Application.ScreenUpdating = True
    MsgBox "done"
End Sub

Sub Modified_aaa_v1()
'JumpTo label naming by calibration name and data entry to excel PPG file
'Add Calibration label name for Jumpto Name. Example: (CAL_1) or (QUA_1), _
  etc. except do not use (QUA_1a).
Dim xlCalc As XlCalculation
Dim RwIndex As Long
Dim LRow As Long
Dim sCalName As String
Dim ShtToChange As Worksheet
Dim RwOffset As Long
    With Application
        xlCalc = .Calculation
'        .Calculation = xlCalculationManual
'        .ScreenUpdating = False
        .EnableEvents = False
    End With
    On Error GoTo ExitPoint
    Set ShtToChange = ThisWorkbook.Worksheets("Sheet1")
    With ShtToChange
        LRow = .Range("A1").End(xlDown).Row
        'sample search string. MEAS/SPHERE,F(QUA_1),5
        For RwIndex = LRow To 2 Step -1
            RwOffset = 0
            With .Cells(RwIndex, "A")
                If Left(.Value2, 13) = "MEAS/SPHERE,F" Then
                    'find left "(" and then right ")" string example: "(CAL_1)"
                    sCalName = Mid(.Value2, InStr(.Value2, "("), InStr(.Value2, ")") - InStr(.Value2, "(") + 1)
                End If
                'Add calibration label name. example: (QUA_1)
                If sCalName <> "(QUA_1)" Then
                    If Left(.Value2, 8) = "SNSLCT/S" Then
                        If .Value2 <> "SNSLCT/S(S1)" Then
                            .EntireRow.Insert Shift:=xlDown
                            RwOffset = -1
                        End If
                        With .Offset(RwOffset, 0)
                            If .Offset(-1, 0).Value2 <> "RECALL/D(COORD1),DISK" Then
                                .Value2 = sCalName
                            Else
                                Stop
                            End If
                        End With
                    End If
                End If
            End With
        Next RwIndex
        'Add "RECALL/D(COORD1),DISK" after new Jumpto label name
        'sample search string. MEAS/SPHERE,F(QUA_1),5
        LRow = .Range("A1").End(xlDown).Row
        For RwIndex = LRow To 2 Step -1
            RwOffset = 0
            With .Cells(RwIndex, "A")
                Select Case True
                    Case Left(.Value2, 13) = "MEAS/SPHERE,F"
                        If .Offset(-1, 0).Value2 <> "RECALL/D(COORD1),DISK" Then
                            'find left "(" and then right ")" string example: "(CAL_1)"
                            sCalName = Mid(.Value2, InStr(.Value2, "("), InStr(.Value2, ")") - InStr(.Value2, "(") + 1)
                        End If
                    Case Left(.Value2, 8) = "SNSLCT/S"
                        With .Offset(-1, 0)
                            If .Value2 = sCalName Then
                                If .Value2 <> "(QUA_1)" Then
                                    .Offset(1, 0).EntireRow.Insert Shift:=xlDown
'                                    RwOffset = -1
                                   .Offset(1, 0).Value2 = "RECALL/D(COORD1),DISK"
                                Else
                                End If
                            End If
                        End With
                    Case Else
                        'do nothing
                End Select
            End With
        Next RwIndex

        'Re-run loop for (QUA_1) label
        LRow = .Range("A1").End(xlDown).Row
        For RwIndex = LRow To 2 Step -1
            RwOffset = 0
            With .Cells(RwIndex, "A")
                If .Value2 = "MEAS/SPHERE,F(QUA_1),5" Then
                    With .Offset(-2, 0)
                        If Right(.Offset(-1, 0).Value2, 7) <> "-0.4999" Then
                            .EntireRow.Insert Shift:=xlDown
                            RwOffset = -1
                            .Offset(RwOffset, 0).Value2 = "(QUA_1)"
                        End If
                    End With
                End If
            End With
        Next RwIndex
        .Range("A1").Activate
    End With
ExitPoint:
    With Application
        .Calculation = xlCalc
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    Set ShtToChange = Nothing
    Application.ScreenUpdating = True
    MsgBox "done"
End Sub

hth
Rob