Order of Events In Code Wrong

A

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
4,564
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
The code below is launched by a click of a shape on my worksheet.

There are no errors, and it for the most part is performing the core needs. The one thing it isn't doing, is formatting my shape properly.
The very first process in this code is to change the status and formatting of different shapes. One is the shape that the user clicked to enable the code. It's supposed to turn the border of the clicked shape green.

It does this, but only after all the code is executed. What I was aiming for was for the shape to format, then to run the code, not the other way around. The green highlighting of the shape is a visual indication to the user what shape was pressed and what code is running. Any idea how I can achieve the results I am looking for?

Rich (BB code): 
Sub emp_delete()
    'Stop
    Dim rbupath As String, mbupath As String
    Dim ws_postm As Worksheet
    Dim ws_postr As Worksheet
   
   'ScreenUpdating = True
    MsgBox "Employee Delete"
    mbevents = False
    With ws_staffrec
        With .Shapes("emp_delete_b").Line
            .ForeColor.RGB = RGB(131, 249, 43) 'green
        End With
        With .Shapes("emp_edit_b").Line
            .ForeColor.RGB = RGB(56, 93, 138)
            .Visible = False
        End With
        .Shapes("emp_edit_g").Visible = True
        With .Shapes("emp_submit_b").Line
            .ForeColor.RGB = RGB(56, 93, 138)
            .Visible = False
        End With
        .Shapes("emp_submit_g").Visible = True
    End With
   
    ui1 = MsgBox("By continuing this action:" & Chr(13) & "     - this employee will be removed from the roster; " & Chr(13) & _
        "     - all shifts assigned to this employee will be vacated" & Chr(13) & Chr(13) & "Are you certain you wish to proceed?", vbCritical + vbYesNo, "CRITICAL DATA LOSS")
    If ui1 = vbNo Then
        mbevents = True
        Exit Sub
    End If
    'Stop
    'backup
    rbupath = "D:\WSOP 2020\Backup\Roster\"
    mbupath = "D:\WSOP 2020\Backup\Master\"
   
    Application.ScreenUpdating = False
    Set newbook = Workbooks.Add
    Workbooks("SOP Schedule.xlsm").Worksheets("Master").Copy Before:=newbook.Sheets(1)
    fname = Format(Now, "yy-mm-dd.hhmm") & "_BUmaster.xlsx"
    Application.DisplayAlerts = False
    newbook.SaveAs Filename:=mbupath & fname
    newbook.Close
    MsgBox "MASTER schedule backed up.No changes have been made.", , fname
   
    Set newbook = Workbooks.Add
    Workbooks("SOP Schedule.xlsm").Worksheets("ROSTER").Copy Before:=newbook.Sheets(1)
    fname = Format(Now, "yy-mm-dd.hhmm") & "_BUroster.xlsx"
    newbook.SaveAs Filename:=rbupath & fname
    newbook.Close
    MsgBox "ROSTER schedule backed up. No changes have been made.", , fname
   
    Workbooks.Open Filename:="D:\WSOP 2020\Backup\EmployeeArchive\PostSchedule.xlsx"
    Workbooks("PostSchedule.xlsx").Windows(1).Visible = False
    Workbooks.Open Filename:="D:\WSOP 2020\Backup\EmployeeArchive\PostRoster.xlsx"
    Workbooks("PostRoster.xlsx").Windows(1).Visible = False
   
    Set ws_postm = Workbooks("PostSchedule.xlsx").Worksheets("PostSchedule")
    Set ws_postr = Workbooks("PostRoster.xlsx").Worksheets("PostRoster")
   
    'transfer roster entry
    en = ws_staffrec.Range("B6").Value
    srow = Application.WorksheetFunction.Match(en, ws_roster.Columns(1), 0)
    drow = ws_postr.Cells(ws_postr.Rows.Count, "A").End(xlUp).Row + 1
    ws_roster.Rows(srow).Copy
    Workbooks("PostRoster.xlsx").Windows(1).Visible = True
    ws_roster.Rows(srow).Copy ws_postr.Rows(drow)
    Workbooks("PostRoster.xlsx").Close SaveChanges:=True

    'transfer master schedule
    col_ref = ws_roster.Cells(srow, 9)
    Set s_rng = ws_master.Columns(col_ref).Resize(, 5)
    d_col = ws_postm.Cells(2, ws_postm.Columns.Count).End(xlToLeft).Column
    Workbooks("PostSchedule.xlsx").Windows(1).Visible = True
    s_rng.Copy ws_postm.Columns(d_col + 1)
    With ws_postm
        .Cells(1, d_col + 1) = ws_roster.Cells(srow, 1)
        .Cells(1, d_col + 2) = ws_roster.Cells(srow, 5)
         .Cells(3, d_col + 1) = ws_roster.Cells(srow, 4)
    End With
    Workbooks("PostSchedule.xlsx").Close SaveChanges:=True
   
    'adjust roster
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
 
Last edited by a moderator:

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
Is screen updating set to false in the missing first part of the code?
 
Upvote 0
Hello Jason,
Looks like I missed pasting the first part of the code.
But to answer your question, to rule that out, I did put in a line to turn screenupdating back on just in case it was off, but it didn't appear to make a difference.

Here's the full code:
Rich (BB code): 
Sub emp_delete()
    'Stop
    Dim rbupath As String, mbupath As String
    Dim ws_postm As Worksheet
    Dim ws_postr As Worksheet
   
    Application.ScreenUpdating = True  'just to make sure
    MsgBox "Employee Delete"
    mbevents = False
    With ws_staffrec
        With .Shapes("emp_delete_b").Line
            .ForeColor.RGB = RGB(131, 249, 43) 'green
        End With
        With .Shapes("emp_edit_b").Line
            .ForeColor.RGB = RGB(56, 93, 138)
            .Visible = False
        End With
        .Shapes("emp_edit_g").Visible = True
        With .Shapes("emp_submit_b").Line
            .ForeColor.RGB = RGB(56, 93, 138)
            .Visible = False
        End With
        .Shapes("emp_submit_g").Visible = True
    End With
   
    ui1 = MsgBox("By continuing this action:" & Chr(13) & "     - this employee will be removed from the roster; " & Chr(13) & _
        "     - all shifts assigned to this employee will be vacated" & Chr(13) & Chr(13) & "Are you certain you wish to proceed?", vbCritical + vbYesNo, "CRITICAL DATA LOSS")
    If ui1 = vbNo Then
        mbevents = True
        Exit Sub
    End If
    'Stop
    'backup
    rbupath = "D:\WSOP 2020\Backup\Roster\"
    mbupath = "D:\WSOP 2020\Backup\Master\"
   
    Application.ScreenUpdating = False
    Set newbook = Workbooks.Add
    Workbooks("SOP Schedule.xlsm").Worksheets("Master").Copy Before:=newbook.Sheets(1)
    fname = Format(Now, "yy-mm-dd.hhmm") & "_BUmaster.xlsx"
    Application.DisplayAlerts = False
    newbook.SaveAs Filename:=mbupath & fname
    newbook.Close
    MsgBox "MASTER schedule backed up.No changes have been made.", , fname
   
    Set newbook = Workbooks.Add
    Workbooks("SOP Schedule.xlsm").Worksheets("ROSTER").Copy Before:=newbook.Sheets(1)
    fname = Format(Now, "yy-mm-dd.hhmm") & "_BUroster.xlsx"
    newbook.SaveAs Filename:=rbupath & fname
    newbook.Close
    MsgBox "ROSTER schedule backed up. No changes have been made.", , fname
   
    Workbooks.Open Filename:="D:\WSOP 2020\Backup\EmployeeArchive\PostSchedule.xlsx"
    Workbooks("PostSchedule.xlsx").Windows(1).Visible = False
    Workbooks.Open Filename:="D:\WSOP 2020\Backup\EmployeeArchive\PostRoster.xlsx"
    Workbooks("PostRoster.xlsx").Windows(1).Visible = False
   
    Set ws_postm = Workbooks("PostSchedule.xlsx").Worksheets("PostSchedule")
    Set ws_postr = Workbooks("PostRoster.xlsx").Worksheets("PostRoster")
   
    'transfer roster entry
    en = ws_staffrec.Range("B6").Value
    srow = Application.WorksheetFunction.Match(en, ws_roster.Columns(1), 0)
    drow = ws_postr.Cells(ws_postr.Rows.Count, "A").End(xlUp).Row + 1
    ws_roster.Rows(srow).Copy
    Workbooks("PostRoster.xlsx").Windows(1).Visible = True
    ws_roster.Rows(srow).Copy ws_postr.Rows(drow)
    Workbooks("PostRoster.xlsx").Close SaveChanges:=True

    'transfer master schedule
    col_ref = ws_roster.Cells(srow, 9)
    Set s_rng = ws_master.Columns(col_ref).Resize(, 5)
    d_col = ws_postm.Cells(2, ws_postm.Columns.Count).End(xlToLeft).Column
    Workbooks("PostSchedule.xlsx").Windows(1).Visible = True
    s_rng.Copy ws_postm.Columns(d_col + 1)
    With ws_postm
        .Cells(1, d_col + 1) = ws_roster.Cells(srow, 1)
        .Cells(1, d_col + 2) = ws_roster.Cells(srow, 5)
         .Cells(3, d_col + 1) = ws_roster.Cells(srow, 4)
    End With
    Workbooks("PostSchedule.xlsx").Close SaveChanges:=True
   
    'adjust roster
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
 
Upvote 0
If you're 100% certain that the code is working with the correct shape, then that is the only possible reason why you wouldn't see the change.

As far as I know, shape changes are still handled within excel so I can't see that DoEvents would help.

To the best of my (limited) knowledge, everything should happen in the order that it is written in the code.
 
Upvote 0
Thanks Jason for your input. It is odd.
Yes ... the right shape does eventually get the green border, but at the end of the code execution, not the beginning where its coded.
Maybe someone else is able find something.
 
Upvote 0
When a macro changes the image of a shape, that change isn't visible until the whole of the routine is done unless you force a screen refresh with Application.ScreenUpdating = True.
Not just leaving it on, but forcing an update.

VBA Code: 
Sub emp_delete()
  
    Dim rbupath As String, mbupath As String
    Dim ws_postm As Worksheet
    Dim ws_postr As Worksheet
   
   'ScreenUpdating = True
    MsgBox "Employee Delete"
    mbevents = False
    With ws_staffrec
        With .Shapes("emp_delete_b").Line
            .ForeColor.RGB = RGB(131, 249, 43) 'green
        End With
        With .Shapes("emp_edit_b").Line
            .ForeColor.RGB = RGB(56, 93, 138)
            .Visible = False
        End With
        .Shapes("emp_edit_g").Visible = True
        With .Shapes("emp_submit_b").Line
            .ForeColor.RGB = RGB(56, 93, 138)
            .Visible = False
        End With
        .Shapes("emp_submit_g").Visible = True
    End With

Application.ScreenUpdating = True : Rem forces screen to update

'....
 
Upvote 0
Thank you Mike. This was a very important tidbit of information to learn.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
Page Protecting Itself After Everychange
Replies
3
Views
557
Fluff
Fluff
A
  • Question
Worksheet Change and WorksheetDoubleClick events Not Working - Poor range definitions?
Replies
1
Views
890
Ark68
A
A
  • Question
VBA Formatting Code Formatting Wrong Range of Cells
Replies
3
Views
680
JLGWhiz
JLGWhiz
A
  • Question
Problem With Scrolling Data Through A Static Display Range
Replies
5
Views
927
Ark68
A

Forum statistics

Threads
1,214,596
Messages
6,120,438
Members
448,966
Latest member
DannyC96

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top