Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

VBA Excel Application.ScreenUpdating = False not working

Posted on 2016-09-13
12
Medium Priority
?
782 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 22

Expert Comment

by:Roy Cox
ID: 41796422
What is the code in this Procedure?
0
 

Author Comment

by:DAVID131
ID: 41796546
The code is shown in the attachment screen-flicker.docx
0
 
LVL 22

Expert Comment

by:Roy Cox
ID: 41797301
Sorry I meant in the procedure called during the code

   Three_filters_argument ws
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:DAVID131
ID: 41797350
Good Morning

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

Expert Comment

by:Roy Cox
ID: 41799224
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
ID: 41799308
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
 

Author Comment

by:DAVID131
ID: 41799616
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 22

Expert Comment

by:Roy Cox
ID: 41800175
I'll look at it later when I have more time probably tomorrow.
0
 
LVL 22

Accepted Solution

by:
Roy Cox earned 2000 total points
ID: 41802708
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
ID: 41803729
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
ID: 41803741
Thanks for resolving this despite the constraints
0
 
LVL 22

Expert Comment

by:Roy Cox
ID: 41803744
Pleased to help, although a workbook would have helped.
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
There are times when I have encountered the need to decompress a response from a PHP request. This is how it's done, but you must have control of the request and you can set the Accept-Encoding header.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

916 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