CODEWITHSUNDEEP
performanceexcelfor-loopvba
accortdr
accortdr

Reputation: 91

Improve Looping Efficiency in VBA

I have a For loop that loops through integers 1 to 9 and simply finds the bottom most entry that corresponds to that integer ( i.e. 1,1,1,2,3,4,5 would find the 3rd "1" entry) and inserts a blank row. I concatenate the number with a string "FN" that just corresponds to the application for this code, just to clarify. Anyway, it works well, but it lags quite a bit for only having to run through 9 integers. I was hoping someone would be able to help me debug to improve speed on this code. Thanks! Bonus points if anyone can shed some light on a good way to populate the blank row being inserted with a formatted copy of the header of the page that spans ("A1:L1"). The code I attempted is commented out right before Next i.

Sub test()

Dim i As Integer, Line As String, Cards As Range
Dim Head As Range, LR2 As Long


        For i = 1 To 9
    Line = "FN" & CStr(i)
    Set Cards = Sheets(1).Cells.Find(Line, after:=Cells(1, 1), searchdirection:=xlPrevious)

    Cards.Rows.Offset(1).EntireRow.Insert
    Cards.Offset(1).EntireRow.Select
'    Range("A" & (ActiveCell.Row), "K" & (ActiveCell.Row)) = Range("A3:K3")
'    Range("A" & (ActiveCell.Row), "K" & (ActiveCell.Row)).Font.Background = Range("A3:K3").Font.Background

     Next i


End Sub

Upvotes: 1

Views: 95

Answers (2)

user4039065
user4039065

Reputation:

Most of your improvements will come from altering the application environment variables with the appTGGL helper function but there are a few tweaks in the base code here.

Option Explicit

Sub ewrety()
    Dim f As Long, fn0 As String, fndfn As Range

    'appTGGL btggl:=false   'uncomment this when you are confident in it

    With Worksheets(1).Columns("F")
        For f = 1 To 9
            fn0 = Format$(f, "\F\N0")
            Set fndfn = .Find(What:=fn0, After:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, _
                              SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
            With fndfn
                .Offset(1, -5).EntireRow.Insert Shift:=xlDown
                .Parent.Range("A1:L1, XFC1").Copy Destination:=.Offset(1, -5)
            End With
        Next f
    End With

    appTGGL
End Sub

Public Sub appTGGL(Optional bTGGL As Boolean = True)
    With Application
        .ScreenUpdating = bTGGL
        .EnableEvents = bTGGL
        .DisplayAlerts = bTGGL
        .AutoRecover.Enabled = bTGGL   'no interruptions with an auto-save
        .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
        .CutCopyMode = False
        .StatusBar = vbNullString
    End With
    Debug.Print Timer
End Sub

enter image description here

Upvotes: 0

Siddharth Rout
Siddharth Rout

Reputation: 149335

This works pretty fast for me

Sub Sample()
    Dim i As Long, line As String, Cards As Range

    With Sheets(1)
        For i = 1 To 9
            line = "FN" & i

            Set Cards = .Columns(6).Find(line, LookIn:=xlValues, lookat:=xlWhole)

            If Not Cards Is Nothing Then
                .Range("A3:K3").Copy
                Cards.Offset(1, -5).Insert Shift:=xlDown
            End If
         Next i
    End With
End Sub

Before

enter image description here

After enter image description here

Upvotes: 6

Related Questions