Consulting

Results 1 to 13 of 13

Thread: How to speed up VBA Code

  1. #1
    VBAX Regular
    Joined
    Feb 2018
    Posts
    12
    Location

    How to speed up VBA Code

    I am new to working with VBA and have designed a Darts Score Sheet for my local League. I have written the following VBA Code to add an extra Row for lower grade players but due to the length of code it slows down the worksheet. Is there any way of condensing the mathematics to make the code run quicker. Any assistance would be appreciated.

    Private Sub Worksheet_Change(ByVal Target As Range)
    ActiveSheet.Unprotect GeneralPassword
        If Range("AW29").Value = "1" Then
            Rows("30:30").EntireRow.Hidden = False
        ElseIf Range("AW29").Value = "" Then
            Rows("30:30").EntireRow.Hidden = True
        End If
        If Range("AW31").Value = "1" Then
            Rows("32:32").EntireRow.Hidden = False
        ElseIf Range("AW31").Value = "" Then
            Rows("32:32").EntireRow.Hidden = True
        End If
        If Range("AW33").Value = "1" Then
            Rows("34:34").EntireRow.Hidden = False
        ElseIf Range("AW33").Value = "" Then
            Rows("34:34").EntireRow.Hidden = True
        End If
        If Range("AW35").Value = "1" Then
            Rows("36:36").EntireRow.Hidden = False
        ElseIf Range("AW35").Value = "" Then
            Rows("36:36").EntireRow.Hidden = True
        End If
        If Range("AW37").Value = "1" Then
            Rows("38:38").EntireRow.Hidden = False
        ElseIf Range("AW37").Value = "" Then
            Rows("38:38").EntireRow.Hidden = True
        End If
        If Range("AW39").Value = "1" Then
            Rows("40:40").EntireRow.Hidden = False
        ElseIf Range("AW39").Value = "" Then
            Rows("40:40").EntireRow.Hidden = True
        End If
        If Range("AW41").Value = "1" Then
            Rows("42:42").EntireRow.Hidden = False
        ElseIf Range("AW41").Value = "" Then
            Rows("42:42").EntireRow.Hidden = True
        End If
        If Range("AW43").Value = "1" Then
            Rows("44:44").EntireRow.Hidden = False
        ElseIf Range("AW43").Value = "" Then
            Rows("44:44").EntireRow.Hidden = True
        End If
        If Range("AW45").Value = "1" Then
            Rows("46:46").EntireRow.Hidden = False
        ElseIf Range("AW45").Value = "" Then
            Rows("46:46").EntireRow.Hidden = True
        End If
        If Range("AW47").Value = "1" Then
            Rows("48:48").EntireRow.Hidden = False
        ElseIf Range("AW47").Value = "" Then
            Rows("48:48").EntireRow.Hidden = True
        End If
        If Range("AW49").Value = "1" Then
            Rows("50:50").EntireRow.Hidden = False
        ElseIf Range("AW49").Value = "" Then
            Rows("50:50").EntireRow.Hidden = True
        End If
        If Range("AW51").Value = "1" Then
            Rows("52:52").EntireRow.Hidden = False
        ElseIf Range("AW51").Value = "" Then
            Rows("52:52").EntireRow.Hidden = True
        End If
        If Range("AW53").Value = "1" Then
            Rows("54:54").EntireRow.Hidden = False
        ElseIf Range("AW53").Value = "" Then
            Rows("54:54").EntireRow.Hidden = True
        End If
        If Range("AW55").Value = "1" Then
            Rows("56:56").EntireRow.Hidden = False
        ElseIf Range("AW55").Value = "" Then
            Rows("56:56").EntireRow.Hidden = True
        End If
        If Range("AW57").Value = "1" Then
            Rows("58:58").EntireRow.Hidden = False
        ElseIf Range("AW57").Value = "" Then
            Rows("58:58").EntireRow.Hidden = True
        End If
        If Range("AW59").Value = "1" Then
            Rows("60:60").EntireRow.Hidden = False
        ElseIf Range("AW59").Value = "" Then
            Rows("60:60").EntireRow.Hidden = True
        End If
        If Range("AW61").Value = "1" Then
            Rows("62:62").EntireRow.Hidden = False
        ElseIf Range("AW61").Value = "" Then
            Rows("62:62").EntireRow.Hidden = True
        End If
        If Range("AW63").Value = "1" Then
            Rows("64:64").EntireRow.Hidden = False
        ElseIf Range("AW63").Value = "" Then
            Rows("64:64").EntireRow.Hidden = True
        End If
    ActiveSheet.Protect GeneralPassword
            
    End Sub

  2. #2
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    Ride the wind to the sun
    Posts
    2,594
    welcome to the forum.

    it's not the length only but the code itself.
    this is a change event so it fires everytime you change a cell.
    define the cells that you really want to trigger the event.f

    below may give you an idea...

        If Target.Count > 1 Then Exit Sub
           'fire only when one cell is changed
        If Intersect(Target, Range("C1:C3")) Is Nothing Then Exit Sub
           'fire only when one cell in range C1:C3 is changed
    
        With Target
            If .Address = "$C$1" Then
               'code lines when C1 is changed
            ElseIf .Address = "$C$2" Then
               'code lines when C2 is changed
            ElseIf .Address = "$C$3" Then
               'code lines when C3 is changed
            End If
        End With
    you can find many ways...

    PS
    for a noncontiguous range:
    If Intersect(Target, Union(Range("C1"), Range("C5"), Range("C9")) Is Nothing Then Exit Sub
    Last edited by mancubus; 02-05-2018 at 03:35 AM. Reason: corrections in comments
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  3. #3
    VBAX Regular
    Joined
    Feb 2018
    Posts
    12
    Location
    Thanks mancubus, I will have to research what you have said as I really am new at this and thought that I had defined the actual cells I want to trigger.

  4. #4
    VBAX Guru mancubus's Avatar
    Joined
    Dec 2010
    Location
    Ride the wind to the sun
    Posts
    2,594
    you're welcome.

    if you don't explicitly define the "Target" cell, the event code triggers whenever a cell is changed.

    if this is what you are after, that's ok. but in most of the cases there are some rules, restrictions, specifications. so design your code according to these rules. if you dont have any rules, you'd better review your Project.
    PLS DO NOT PM; OPEN A THREAD INSTEAD!!!

    1) Posting Code
    [CODE]PasteYourCodeHere[/CODE]
    (or paste your code, select it, click # button)

    2) Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific / sensitive / confidential data. Include so many rows and sheets etc in the uploaded workbook to enable the helpers visualize the data and table structure. Helpers do not need the entire workbook.

    3) Testing the Codes
    always back up your files before testing the codes.

    4) Marking the Thread as Solved
    from Thread Tools (on the top right corner, above the first message)

  5. #5
    VBAX Expert
    Joined
    May 2016
    Posts
    603
    Location
    One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
    To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
    So instead of writing software that goes down a range checking one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then check the vaalues in the variant array .
    Your software check every cell twice in the 30 rows you are looking at. I have modified your software so that it loads all the dat into a varaint array and then check the array for the condition. This will speed it up regardless of whether you sort the target intersect bit out.


    Private Sub Worksheet_Change(ByVal Target As Range)
        ActiveSheet.Unprotect GeneralPassword
        inarr = Range("AW1:Aw63")
        
    If inarr(29, 1) = "1" Then
            Rows("30:30").EntireRow.Hidden = False
        ElseIf inarr(29, 1) = "" Then
            Rows("30:30").EntireRow.Hidden = True
        End If
    If inarr(31, 1) = "1" Then
            Rows("32:32").EntireRow.Hidden = False
        ElseIf inarr(31, 1) = "" Then
            Rows("32:32").EntireRow.Hidden = True
        End If
    If inarr(33, 1) = "1" Then
            Rows("34:34").EntireRow.Hidden = False
        ElseIf inarr(33, 1) = "" Then
            Rows("34:34").EntireRow.Hidden = True
        End If
    If inarr(35, 1) = "1" Then
            Rows("36:36").EntireRow.Hidden = False
        ElseIf inarr(35, 1) = "" Then
            Rows("36:36").EntireRow.Hidden = True
        End If
    If inarr(37, 1) = "1" Then
            Rows("38:38").EntireRow.Hidden = False
        ElseIf inarr(37, 1) = "" Then
            Rows("38:38").EntireRow.Hidden = True
        End If
    If inarr(39, 1) = "1" Then
            Rows("40:40").EntireRow.Hidden = False
        ElseIf inarr(39, 1) = "" Then
            Rows("40:40").EntireRow.Hidden = True
        End If
    If inarr(41, 1) = "1" Then
            Rows("42:42").EntireRow.Hidden = False
        ElseIf inarr(41, 1) = "" Then
            Rows("42:42").EntireRow.Hidden = True
        End If
    If inarr(43, 1) = "1" Then
            Rows("44:44").EntireRow.Hidden = False
        ElseIf inarr(43, 1) = "" Then
            Rows("44:44").EntireRow.Hidden = True
        End If
    If inarr(45, 1) = "1" Then
            Rows("46:46").EntireRow.Hidden = False
        ElseIf inarr(45, 1) = "" Then
            Rows("46:46").EntireRow.Hidden = True
        End If
    If inarr(47, 1) = "1" Then
            Rows("48:48").EntireRow.Hidden = False
        ElseIf inarr(47, 1) = "" Then
            Rows("48:48").EntireRow.Hidden = True
        End If
    If inarr(49, 1) = "1" Then
            Rows("50:50").EntireRow.Hidden = False
        ElseIf inarr(49, 1) = "" Then
            Rows("50:50").EntireRow.Hidden = True
        End If
    If inarr(51, 1) = "1" Then
            Rows("52:52").EntireRow.Hidden = False
        ElseIf inarr(51, 1) = "" Then
            Rows("52:52").EntireRow.Hidden = True
        End If
    If inarr(53, 1) = "1" Then
            Rows("54:54").EntireRow.Hidden = False
        ElseIf inarr(53, 1) = "" Then
            Rows("54:54").EntireRow.Hidden = True
        End If
    If inarr(55, 1) = "1" Then
            Rows("56:56").EntireRow.Hidden = False
        ElseIf inarr(55, 1) = "" Then
            Rows("56:56").EntireRow.Hidden = True
        End If
    If inarr(57, 1) = "1" Then
            Rows("58:58").EntireRow.Hidden = False
        ElseIf inarr(57, 1) = "" Then
            Rows("58:58").EntireRow.Hidden = True
        End If
    If inarr(59, 1) = "1" Then
            Rows("60:60").EntireRow.Hidden = False
        ElseIf inarr(59, 1) = "" Then
            Rows("60:60").EntireRow.Hidden = True
        End If
    If inarr(61, 1) = "1" Then
            Rows("62:62").EntireRow.Hidden = False
        ElseIf inarr(61, 1) = "" Then
            Rows("62:62").EntireRow.Hidden = True
        End If
    If inarr(63, 1) = "1" Then
            Rows("64:64").EntireRow.Hidden = False
        ElseIf inarr(63, 1) = "" Then
            Rows("64:64").EntireRow.Hidden = True
        End If
        ActiveSheet.Protect GeneralPassword
         
    
    
    End Sub

  6. #6
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,580
    Why not using autofilter ?

    sub M_snb()
       columns(1).autofilter 1,1
    End Sub

  7. #7
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,598
    One of these perhaps:
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim HiddenRows As Range
    Dim ShowingRows As Range
    myVals = Range("aw1:aw63").Value
    For rw = 29 To 63 Step 2
      If myVals(rw, 1) = 1 Then
        If ShowingRows Is Nothing Then Set ShowingRows = Cells(rw + 1, 1) Else Set ShowingRows = Union(ShowingRows, Cells(rw + 1, 1))
      ElseIf myVals(rw, 1) = "" Then
        If HiddenRows Is Nothing Then Set HiddenRows = Cells(rw + 1, 1) Else Set HiddenRows = Union(HiddenRows, Cells(rw + 1, 1))
      End If
    Next rw
    ActiveSheet.Unprotect GeneralPassword
    If Not ShowingRows Is Nothing Then ShowingRows.EntireRow.Hidden = False
    If Not HiddenRows Is Nothing Then HiddenRows.EntireRow.Hidden = True
    ActiveSheet.Protect GeneralPassword
    End Sub
    Sub Worksheet_Change(ByVal Target As Range)
    Dim CellsToCheckThisTime As Range, HiddenRows As Range, ShowingRows As Range
    Set rngToCheck = Range("AW29 , AW31, AW33, AW35, AW37, AW39, AW41, AW43, AW45, AW47, AW49, AW51, AW53, AW55, AW57, AW59, AW61, AW63")
    Set CellsToCheckThisTime = Intersect(Target, rngToCheck)
    If Not CellsToCheckThisTime Is Nothing Then
      For Each cll In CellsToCheckThisTime.Cells
        If cll.Value = 1 Then
          If ShowingRows Is Nothing Then Set ShowingRows = cll.Offset(1) Else Set ShowingRows = Union(ShowingRows, cll.Offset(1))
        ElseIf cll.Value = "" Then
          If HiddenRows Is Nothing Then Set HiddenRows = cll.Offset(1) Else Set HiddenRows = Union(HiddenRows, cll.Offset(1))
        End If
      Next cll
      ActiveSheet.Unprotect GeneralPassword
      If Not ShowingRows Is Nothing Then ShowingRows.EntireRow.Hidden = False
      If Not HiddenRows Is Nothing Then HiddenRows.EntireRow.Hidden = True
      ActiveSheet.Protect GeneralPassword
    End If
    End Sub
    Realise though, that if you put anything but a 1 or nothing in the cells being checked that the row below won't change its hidden property. The code could be shorter if you just checked for empty cells (or not).
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  8. #8
    VBAX Regular
    Joined
    Feb 2018
    Posts
    12
    Location
    Thank you offthelip, this did reduce the time to activate the extra rows. Your assistance was really appreciated.

  9. #9
    VBAX Regular
    Joined
    Feb 2018
    Posts
    12
    Location
    Thank you p45cal, I tried both of your posts. The first one works really well but the second one didn't work at all. I have implemented your first post for trials by the dart league. Once again thank you for your assistance it is really appreciated.

  10. #10
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,598
    I tested both and they both work.
    You didn't have them both at the same time in the same sheet-module dod you? Only one of them will work (usually the top one). To test the other, temporarily rename one of them, eg.:
    Sub Worksheet_Change(ByVal Target As Range)
    becomes:
    Sub zzzWorksheet_Change(ByVal Target As Range)
    then the remaining one will work.
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  11. #11
    VBAX Regular
    Joined
    Feb 2018
    Posts
    12
    Location
    No p45cal I dont have them both in the same work sheet. I have 5 copies of the work sheet and have my original code in one, your codes in two and three, offthelip's in four and a modified original using mancubus's tips in five. Your top code works the fastest and I can't get your other code to work. Will try again tomorrow Australian time.

  12. #12
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,598
    Quote Originally Posted by Stealth View Post
    …but the second one didn't work at all.
    In the attached, one sheet, with the second macro in msg#7 copy/pasted into the sheet's code-module. Works fine here.
    Attached Files Attached Files
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  13. #13
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    6,898
    Location
    Interesting situation. Here's my 2 cents.

    This is based on one premise, one assumption, and one presumption


    • Presupposed that any Event Sub should only decide what other subs/functions to run. Do not Overload an Event sub such that it cannot coherently handle multiple events in different manners.
    • Assumes that you don't care about changing all rows every time one cell is changed.
    • Presumes that there may come a time when you want to reset all rows that can be hidden.


    WorkSheet Code Module:
    Private Sub Worksheet_Change(ByVal Target As Range)
    
    'Deal only with changes to column AW in odd numbered Rows 29 to 63
    If Mid(Target.Address, 2, 2) = "AW" _
      And Target.Row >= 29 And Target.Row <= 63 _
      And (Target.Row Mod 2 = 1) Then
      HideShowRows_AW Target
      Exit Sub
    End If
    
    'Deal with changes elsewhere if needed
    
    End Sub
    Standard Module:
    Sub HideShowRows_AW(ByVal Target As Range)
    Const GeneralPassword As String = "***" ' for debugging purposes
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Target.Parent.Unprotect GeneralPassword
        
    If CStr(Target) = "1" Then
      Target.Offset(1).EntireRow.Hidden = False
    Else
      Target.Offset(1).EntireRow.Hidden = True
    End If
    
    Target.Parent.Protect GeneralPassword
    Application.ScreenUpdating = True
    Application.EnableEvents = True
            
    End Sub
    
    
    Public Sub HideAll_AW()
    Const GeneralPassword As String = "***" ' for debugging purposes
    Dim Rw As Long
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    With ActiveSheet
      .Unprotect GeneralPassword
      
      For Rw = 30 To 64 Step 2
        .Rows(Rw).Hidden = True
      Next
      
     .Protect GeneralPassword
    End With
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    End Sub
    
    Public Sub ShowAll_AW()
    Const GeneralPassword As String = "***" ' for debugging purposes
    Dim Rw As Long
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    With ActiveSheet
      .Unprotect GeneralPassword
      
      For Rw = 30 To 64 Step 2
        .Rows(Rw).Hidden = False
      Next
      
     .Protect GeneralPassword
    End With
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    End Sub
    Note that HideAll_AW, and ShowAll_AW are designed to be called from Excel's Macro menu, allowing the User to reset all hide-able rows to one condition or the other. This ignores "1"s in other cells.
    Please take the time to read the Forum FAQ

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •