Shape Visibility = True not wokring.

[Marhier]

Good day everyone.
I've got a tiny issue I'm hoping someone can help me solve.

I've got a bit of code that takes approximately 20-30 seconds to complete.
While the code is running, a shape is unhidden which displays the text "Please Wait...", and then is hidden again towards the end of the script.

The issue I'm having is, when the code runs, the following line doesn't work:

ActiveSheet.Shapes("PleaseWait").Visible = True

If I manually unhide it and run the code, the Visible = False at the end works as intended.

Weirdly though, when I 'F8' through the code manually in the VBA editor, the "= True" at the beginning works; it just seems to be when you run the entire code - it fails.

I've tried putting the code to hide and unhide the shape in their own subs, and have my main code call on those subs, but the exact same thing happens.

Any help would be greatly appreciated.
Thank you.

My full code is as follows:

Sub RefreshReport()

'Declare Variables
Dim rngData As Range, tblData As ListObject, boolHasZero As Boolean, temp As String, Sheet As Worksheet, Pivot As PivotTable, Answer As VbMsgBoxResult, iWindowState As Integer
Dim CutOffDate As Long

'Notify user of task and ask if they want to continue.
Answer = MsgBox("The report will now be updated." & vbNewLine & "You will be notified once complete." & vbNewLine & "Do you wish to continue?", vbYesNo + vbQuestion + vbDefaultButton2, "Refresh Table")
If Answer = vbYes Then
Else
ActiveSheet.Shapes("PleaseWait").Visible = False
Exit Sub
End If

'Set the cut off date
temp = Application.InputBox("Please enter the cut-off date" & vbNewLine & "'DD/MM/YY'")
CutOffDate = CLng(DateValue(temp))

'Display 'Please Wait' box
[B][U]ActiveSheet.Shapes("PleaseWait").Visible = True[/U][/B]

'Disable Screen Updating
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False

'Unhide and go to 'Data' tab
Data.Visible = xlSheetVisible
Data.Select

'Set Variables for the active sheet
Set tblData = ActiveSheet.ListObjects("Data")

'Clear and refresh query table
Range("Data").Select
Selection.ClearContents
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False

'Populate "Total" column with formula
ActiveSheet.ListObjects("Data").DataBodyRange.Columns(18).FormulaR1C1 = _
        "=IFERROR(SUM([@MOrderQty]*[@MPrice]/[@MConvFactPrcUm]),""0"")"

'Filter table by dates prior to the cut off, clear contents and unfilter the table
tblData.Range.AutoFilter Field:=tblData.ListColumns("OrderEntryDate").Index, Criteria1:="<=" & CutOffDate
tblData.DataBodyRange.ClearContents
tblData.Range.AutoFilter Field:=tblData.ListColumns("OrderEntryDate").Index

'Check if there are any zeros in the 'Total' column
For Each rngData In tblData.DataBodyRange.Columns(tblData.ListColumns("Total").Index).Cells
If rngData.Value = 0 Then
    boolHasZero = True
Exit For
End If
Next rngData

'Filter Table if has zero
If boolHasZero = True Then
    tblData.Range.AutoFilter Field:=tblData.ListColumns("Total").Index, Criteria1:="0"
    tblData.DataBodyRange.ClearContents
    tblData.Range.AutoFilter Field:=tblData.ListColumns("Total").Index
End If

'Sort by newest order entry date
ActiveWorkbook.Worksheets("Data").ListObjects("Data").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Data").ListObjects("Data").Sort.SortFields.Add2 Key _
    :=Range("Data[[#All],[OrderEntryDate]]"), SortOn:=xlSortOnValues, Order:= _
    xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Data").ListObjects("Data").Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

'Delete all blank rows in the table.
tblData.Range.AutoFilter Field:=tblData.ListColumns("Total").Index, Criteria1:=""
tblData.DataBodyRange.EntireRow.Delete
tblData.Range.AutoFilter Field:=tblData.ListColumns("Total").Index

'Repopulate columns with formula.
ActiveSheet.ListObjects("Data").DataBodyRange.Columns(2).FormulaR1C1 = _
        "=IF(XLOOKUP([@Supplier],SupplierNames[Supplier],SupplierNames[Supplier Name])="""","""",XLOOKUP([@Supplier],SupplierNames[Supplier],SupplierNames[Supplier Name]))"
ActiveSheet.ListObjects("Data").DataBodyRange.Columns(16).FormulaR1C1 = _
        "=IF(XLOOKUP([@Supplier],SupplierNames[Supplier],SupplierNames[Master Category])="""","""",XLOOKUP([@Supplier],SupplierNames[Supplier],SupplierNames[Master Category]))"
ActiveSheet.ListObjects("Data").DataBodyRange.Columns(17).FormulaR1C1 = _
        "=IF(XLOOKUP([@Supplier],SupplierNames[Supplier],SupplierNames[Buyer])="""","""",XLOOKUP([@Supplier],SupplierNames[Supplier],SupplierNames[Buyer]))"

Range("A1").Select

'Hide 'Data' tab
Data.Visible = xlSheetVeryHidden

'Unhide and go to 'Data2' tab
Data2.Visible = xlSheetVisible
Data2.Select

'Clear and refresh query table
Range("Data2").Select
Selection.ClearContents
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Range("A1").Select

'Hide 'Data2' tab
Data2.Visible = xlSheetVeryHidden

'Go to 'Home' page.
Home.Select

'Refresh all pivot tables.
For Each Sheet In ThisWorkbook.Worksheets
For Each Pivot In Sheet.PivotTables
    Pivot.RefreshTable
    Pivot.Update
Next
Next

'Enable Screen Updating.
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True

'Remove 'Please Wait' box
ActiveSheet.Shapes("PleaseWait").Visible = False

'Notify user the task has been completed.
MsgBox ("Update Complete.")

End Sub

 

[FormR]

Hi, you could try adding DoEvents directly after ActiveSheet.Shapes("PleaseWait").Visible = True

 

[Marhier]

Unfortunately, that didn't work.

 

[Marhier]

Good day everyone.
Further to this, I've now tried putting the code to unhide the shape in it's own sub, and then have that sub call my "RefreshTable" sub.

So when I run the following code, it works:

Sub UnHideShape()
Answer = MsgBox("The report will now be updated." & vbNewLine & "You will be notified once complete." & vbNewLine & "Do you wish to continue?", vbYesNo + vbQuestion + vbDefaultButton2, "Refresh Table")
If Answer = vbYes Then
Else
ActiveSheet.Shapes("PleaseWait").Visible = False
Exit Sub
End If
ActiveSheet.Shapes("PleaseWait").Visible = True
'Call RefreshReport
End Sub

You'll see that I have blocked the Call RefreshReport line of code.

The moment I do this:

Sub UnHideShape()
Answer = MsgBox("The report will now be updated." & vbNewLine & "You will be notified once complete." & vbNewLine & "Do you wish to continue?", vbYesNo + vbQuestion + vbDefaultButton2, "Refresh Table")
If Answer = vbYes Then
Else
ActiveSheet.Shapes("PleaseWait").Visible = False
Exit Sub
End If
ActiveSheet.Shapes("PleaseWait").Visible = True
Call RefreshReport
End Sub

The shape doesn't unhide.

I'm really baffled here.
Any ideas would be greatly appreciated.

 

[FormR]

You could try adding this directly after changing the visibility of the shape:

ActiveWindow.SmallScroll 0

There's a few other suggestions here too that you could try if the one above doesn't help.

Force a screen update in Excel VBA

My Excel tool performs a long task, and I'm trying to be kind to the user by providing a progress report in the status bar, or in some cell in the sheet, as shown below. But the screen doesn't refr...

stackoverflow.com

 

[Marhier]

Appreciate your response and help.
Unfortunately, none of that seems to work.

Strangely though, if the code is running and I click off the workbook to my desktop, or another program (I have 2 monitors, so can still see Excel), the shape appears just as the "Update Complete" message box pops up.

When I click 'Ok' to that, the shape disappears as intended.

Very strange.

Perhaps I'll try call a User Form over a shape and see if that helps.

 

[FormR]

Perhaps I'll try call a User Form over a shape and see if that helps.

That sounds like a good plan