Solved

VBA Excel Application.ScreenUpdating = False not working

Posted on 2016-09-13
12
64 Views
Last Modified: 2016-09-18
The attached has worked very well - Excel 2010 in Windows 10

The attached sub routine loops through a list of sheets and for each sheet calls in the arguement also shown.
As the model has grown in size I have started to encounter the screen flickering as the macro jumps from one sheet to another - despite screnUpdating being false and also the run time has gone from 1 minute to 4 minutes

The net is awash with this problem and ideas on causes however the use of Select is commonly blamed
Ignorance on my part means that I cannot alter the use of Select in my code to see if the flickering stops.

I would appreciate if someone could give me guidance on how to circumvent the use of Select in this code
SCREEN-FLICKER.docx
0
Comment
Question by:DAVID131
  • 6
  • 6
12 Comments
 
LVL 17

Expert Comment

by:Roy_Cox
Comment Utility
What is the code in this Procedure?
0
 

Author Comment

by:DAVID131
Comment Utility
The code is shown in the attachment screen-flicker.docx
0
 
LVL 17

Expert Comment

by:Roy_Cox
Comment Utility
Sorry I meant in the procedure called during the code

   Three_filters_argument ws
0
 

Author Comment

by:DAVID131
Comment Utility
Good Morning

the code applying to Three_filters_argument ws is shown on pages 2 - 7
0
 
LVL 17

Expert Comment

by:Roy_Cox
Comment Utility
It is so much easier if you attach an example workbook containing the code.

I have attempted to edit your code but I cannot test it. I am sure that the coding could be improved but you don't add any notes to explain in the code. How will you remember what it is doing when you come back to this code later?

You will have to test this and loet me know if any errors occur and the line they occur on.

Sub Admin_filter_loop()
'from admin list loop through sheets and perform argument three filters
    Dim ws As Worksheet, dws As Worksheet, admWs As Worksheet
    Dim lr As Long, alr As Long, i As Long, dlr As Long
    Dim x
    With Application
        .StatusBar = "MACRO IN PROGRESS please wait......"
        .ScreenUpdating = False
        .DisplayAlerts = False

        Set dws = Sheets("percent upload")
        Set admWs = Sheets("Admin")
        'Inserts headers
        dws.Range("A1:F1").Value = Array("Comments", "Branch", "Line", "Layout", "Section", "Override")
        alr = admWs.Cells(Rows.Count, 2).End(xlUp).Row
        If alr < 5 Then
            MsgBox "There are no sheets listed on Admin Sheet.", vbExclamation, "Sheet List Not Found!"
            Exit Sub
        End If
        x = admWs.Range("B5:B" & alr).Value
        For i = 1 To UBound(x, 1)
            Set ws = Sheets(x(i, 1))
            If Not ws Is Nothing Then
                Three_filters_argument ws
            End If
        Next i

        .ScreenUpdating = True
        .DisplayAlerts = True
        .StatusBar = False
    End With

    MsgBox "Data has been copied to Summary Sheet successfully.", vbInformation, "Done!"
End Sub

'Filters ARGUMENT
'APPLY 3 FILTERS
Sub Three_filters_argument(ws As Worksheet)
' three_filters Macr
    Application.ScreenUpdating = False
    'PERFORM FIRST FILTER
    'switch off auto calcs to speed up code
    Application.Calculation = xlCalculationManual
    Dim rRng As Range

    With ws
        If .AutoFilterMode = True Then
            .Range("A1").AutoFilter    ''/// not sure what you expect the selection to be, amend accordingly
        End If

        xrow = .Cells(.Rows.Count, 27).End(xlUp).Row

        .Range("V5").AutoFilter
        .Range("$V$5:$z$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd

        Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)

        'if header row or blank exclude otherwise copy visible rows

        headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
        flag = 0
        For Each rngrow In filteredrange.Rows
            lastrow = rngrow.Row
            If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
                flag = 1
                firstrow = rngrow.Row
            End If
        Next
        If firstrow > 0 Then
            Range("V" & firstrow & ":Z" & lastrow).Copy

            With Sheets("percent upload")

                If .Range("B2").Value = "" Then
                    Set rRng = .Range("B2")
                Else
                    Set rRng = .Range("B1").End(xlDown).Offset(1, 0).Select
                End If

                rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                         :=False, Transpose:=False
                Application.CutCopyMode = False
            End With
        End If

        'PERFORM SECOND FILTER




        If .AutoFilterMode = True Then
            .Range("A1").AutoFilter
        End If

        xrow = .Cells(.Rows.Count, 33).End(xlUp).Row

        Range("AA5").AutoFilter
        .Range("$AA$5:$AE$" & xrow).AutoFilter field:=2, Criteria1:=">1", Operator:=xlAnd

        Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)

        headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
        flag = 0
        For Each rngrow In filteredrange.Rows
            lastrow = rngrow.Row
            If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
                flag = 1
                firstrow = rngrow.Row
            End If
        Next
        If firstrow > 0 Then
            .Range("AA" & firstrow & ":AE" & lastrow).Copy

            With Sheets("percent upload")

                If .Range("B2").Value = "" Then
                    Set rRng = Range("B2")
                Else
                    Set rRng = Range("B1").End(xlDown).Offset(1, 0)
                End If

                rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                         :=False, Transpose:=False
                Application.CutCopyMode = False
            End With
        End If

        'PERFORM THIRD FILTER 7 TIMES i.e each copied set into absolute upload is equivalent to one day

        Dim x



        If .AutoFilterMode = True Then
            .Range("A1").AutoFilter
        End If

        xrow = .Cells(.Rows.Count, 33).End(xlUp).Row

        .Range("AG5").AutoFilter
        .Range("$AG$5:$AH$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd

        Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)

        headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
        flag = 0
        For Each rngrow In filteredrange.Rows
            lastrow = rngrow.Row
            If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
                flag = 1
                firstrow = rngrow.Row
            End If
        Next


        If firstrow > 0 And .Cells(firstrow, "AG") <> "" Then


            Set rRng = .Range("AG" & firstrow & ":AH" & lastrow)

            Let x = 0
            Do While x < 7
                rRng.Copy

                With Sheets("absolute upload")
                    If .Range("A2").Value = "" Then
                        Set rRng = .Range("A2")
                    Else
                        Set rRng = .Range("A1").End(xlDown).Offset(1, 0)
                    End If

                    rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Application.CutCopyMode = False

                    x = x + 1
                End With
            Loop
            '    .Range("a1").Select

        End If

        Application.Calculation = xlCalculationAutomatic
    End With
End Sub

Open in new window

0
 

Author Comment

by:DAVID131
Comment Utility
Good Morning
Thanks for the quick response
Re your comments
Sensitivity issues precluded me attaching the relevant workbook and a mock up would not necessarilly be reflective of the complexity.
When I have a final version of my code I always write up the detail, with comment, in a separate Word Document - just what I do for sensitive workbooks
I will test the code as quickly as I can
Thanks
0
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 

Author Comment

by:DAVID131
Comment Utility
I have run the code and it successfully extracts the data for filters 1 and 2 but for filter 3 the results are corrupted in that it appears not to be looping through each sheet, that has content, 7 seven times also the extracts are incomplete.
Whereas previously the flickering caused by seeing the sheets as the code was working through has gone  now it flickers between a blank excel sheet and my screen-saver.
The run time remains the same.
There were only 4 de-bugs - surprisingly few considering you had nothing to validate with
I do appreciate the difficulty of your trying to this 'in the dark' and I would understand if you feel this is too constrained.
If you decide to soldier on I have attached the code as it now looks with the debugs ironed out
SCREEN-FLICKER-2.docx
0
 
LVL 17

Expert Comment

by:Roy_Cox
Comment Utility
I'll look at it later when I have more time probably tomorrow.
0
 
LVL 17

Accepted Solution

by:
Roy_Cox earned 500 total points
Comment Utility
I'm not sure what is happenin but I think the Filter 3 part should be copying some data and pasting it 7 times.

Test this and see if it works

Sub Admin_filter_loop()
'from admin list loop through sheets and perform argument three filters
    Dim ws As Worksheet, dws As Worksheet, admws As Worksheet
    Dim lr As Long, alr As Long, i As Long, dlr As Long
    Dim x
    With Application
        .StatusBar = "MACRO IN PROGRESS please wait......"
        .ScreenUpdating = False
        .DisplayAlerts = False
        Set dws = Sheets("percent upload")
        Set admws = Sheets("Admin")
        'Inserts headers
        dws.Range("A1:F1").Value = Array("Comments", "Branch", "Line", "Layout", "Section", "Override")
        alr = admws.Cells(Rows.Count, 2).End(xlUp).Row
        If alr < 5 Then
            MsgBox "There are no sheets listed on Admin Sheet.", vbExclamation, "Sheet List Not Found!"
            Exit Sub
        End If
        x = admws.Range("B5:B" & alr).Value
        For i = 1 To UBound(x, 1)
            Set ws = Sheets(x(i, 1))
            If Not ws Is Nothing Then
                Three_filters_argument ws
            End If
        Next i
        .ScreenUpdating = True
        .DisplayAlerts = True
        .StatusBar = False
    End With
    MsgBox "Data has been copied to Summary Sheet successfully.", vbInformation, "Done!"
End Sub
'APPLY 3 FILTERS
Sub Three_filters_argument(ws As Worksheet)
'
    
    '
    'PERFORM FIRST FILTER
    'switch off auto calcs to speed up code
    Application.Calculation = xlCalculationManual
    Dim rRng As Range, rRng2 As Range
    With ws
        If .AutoFilterMode = True Then
            .Range("A1").AutoFilter
        End If
        xrow = .Cells(.Rows.Count, 22).End(xlUp).Row
        .Range("V5").AutoFilter
        .Range("$V$5:$z$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd
        Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
        'if header row or blank exclude otherwise copy visible rows
        headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
        flag = 0
        For Each rngrow In filteredrange.Rows
            lastrow = rngrow.Row
            If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
                flag = 1
                firstrow = rngrow.Row
            End If
        Next
        If firstrow > 0 Then
            .Range("V" & firstrow & ":Z" & lastrow).Copy
            With Sheets("percent upload")
                If .Range("B2").Value = "" Then
                    Set rRng = .Range("B2")
                Else
                    Set rRng = .Range("B1").End(xlDown).Offset(1, 0)
                End If
                rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                         :=False, Transpose:=False
                Application.CutCopyMode = False
            End With
        End If
        'PERFORM SECOND FILTER
        If .AutoFilterMode = True Then
            .Range("A1").AutoFilter
        End If
        xrow = .Cells(.Rows.Count, 27).End(xlUp).Row
        .Range("AA5").AutoFilter
        .Range("$AA$5:$AE$" & xrow).AutoFilter field:=2, Criteria1:=">1", Operator:=xlAnd
        Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
        headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
        flag = 0
        For Each rngrow In filteredrange.Rows
            lastrow = rngrow.Row
            If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
                flag = 1
                firstrow = rngrow.Row
            End If
        Next
        If firstrow > 0 Then
            .Range("AA" & firstrow & ":AE" & lastrow).Copy
            With Sheets("percent upload")
                If .Range("B2").Value = "" Then
                    Set rRng = .Range("B2")
                Else
                    Set rRng = .Range("B1").End(xlDown).Offset(1, 0)
                End If
                rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                         :=False, Transpose:=False
                Application.CutCopyMode = False
            End With
        End If
        'PERFORM THIRD FILTER 7 TIMES i.e each copied set into absolute upload is equivalent to one day
        Dim x As Integer
        If .AutoFilterMode = True Then .Range("A1").AutoFilter
    
        xrow = .Cells(.Rows.Count, 33).End(xlUp).Row
        .Range("AG5").AutoFilter
        .Range("$AG$5:$AH$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd
        Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
        headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
        flag = 0
        For Each rngrow In filteredrange.Rows
            lastrow = rngrow.Row
            If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
                flag = 1
                firstrow = rngrow.Row
            End If
        Next
        If firstrow > 0 And .Cells(firstrow, "AG") <> "" Then
            Set rRng = .Range("AG" & firstrow & ":AH" & lastrow)
              rRng.Copy
              
           x = 0
            Do While x < 8
                With Sheets("absolute upload")
                    If .Range("A2").Value = "" Then
                        Set rRng2 = .Range("A2")
                    Else
                        Set rRng2 = .Range("A1").End(xlDown).Offset(1, 0)
                    End If
                    rRng2.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Application.CutCopyMode = False
                    x = x + 1
                End With
            Loop
        End If
        
    End With
End Sub

Open in new window

0
 

Author Comment

by:DAVID131
Comment Utility
This resolved the previous issue and speeded up performance by c. 20 seconds
Thank you for your perseverance, have learned a lot which can be applied in the future
0
 

Author Closing Comment

by:DAVID131
Comment Utility
Thanks for resolving this despite the constraints
0
 
LVL 17

Expert Comment

by:Roy_Cox
Comment Utility
Pleased to help, although a workbook would have helped.
0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Drop Down List with Unique/Distinct Values (Part II - ComboBox or ListBox and Data Validation List Bonus!) David Miller (dlmille) Intro This article focuses on delivering unique, sorted lists to list objects (e.g., ComboBox, ListBox) and Dat…
Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

771 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now