Worksheet Deactivate

imback2nite

imback2nite

Board Regular
Joined
Oct 30, 2004
Messages
211
Office Version
  1. 2003 or older
Platform
  1. Windows
I'm trying to get a handle on 'Deactivate'. My biggest problem are the users that forget to update the worksheet. I've been using the Command button and here is the code. It works but only when the users hit it. Sigh...
Code: 
Private Sub CommandButton2_Click()
    Application.ScreenUpdating = False
    Addr = ActiveCell.Address
    ActiveSheet.Unprotect "4wink"
    Range("A:E").Copy
    Range("K:O").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A3:E75").ClearContents
    Range("G1:G75").Select
    Selection.Sort Key1:=Range("G1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Selection.Copy
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("I1:I75").Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("I1"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Selection.Copy
    Range("A150").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(2).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("$C2") = "=IF(A2="""","""",INDEX($M:$M,MATCH($A2,$K:$K,0)))"
    Range("$D2") = "=IF(B2="""","""",INDEX($N:$N,MATCH($A2,$K:$K,0)))"
    Range("$E2") = "=IF(C2="""","""",INDEX($O:$O,MATCH($A2,$K:$K,0)))"
    Dim lastRow As Long
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("B2:E2").AutoFill Destination:=Range("B2:E" & lastRow)
    Range("C:E").Copy
    Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("C:E").Replace What:="#N/A", Replacement:=""
    Columns("C:E").Replace What:="0", Replacement:=""
    Columns("K:O").Delete
    Range(Addr).Select
    ActiveSheet.Protect "4wink", DrawingObjects:=False, Contents:=True, Scenarios:=True
    Application.ScreenUpdating = True
End Sub

I've been trying to write a different one for the deactivate but I just can't seem to get it. Any help would be appreciated. I think I'm having problems with 'selection' and how I can't use it if the user is trying to get to another worksheet.

Code: 
Private Sub Worksheet_Deactivate()
    Application.ScreenUpdating = False
    With Sheet3
        .Unprotect "4wink"
        .Range("A:E").Copy
        .Range("K:O").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Range("A3:E75").ClearContents
        .Range("G1:G75").Sort Key1:=Range("G1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Range("G1:G75").Copy
        .Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Range("I1:I75").Sort Key1:=Range("I1"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Range("I1:I75").Copy
        .Range("A150").End(xlUp).ActiveCell.Offset(2).Select
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Application.CutCopyMode = False
        .Range("$C2") = "=IF(A2="""","""",INDEX($M:$M,MATCH($A2,$K:$K,0)))"
        .Range("$D2") = "=IF(B2="""","""",INDEX($N:$N,MATCH($A2,$K:$K,0)))"
        .Range("$E2") = "=IF(C2="""","""",INDEX($O:$O,MATCH($A2,$K:$K,0)))"
    End With
        Dim lastRow As Long
        lastRow = Range("A" & Rows.Count).End(xlUp).Row
    With Sheet3
        .Range("B2:E2").AutoFill Destination:=Range("B2:E" & lastRow)
        .Range("C:E").Copy
        .Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Columns("C:E").Replace What:="#N/A", Replacement:=""
        .Columns("C:E").Replace What:="0", Replacement:=""
        .Columns("K:O").Delete
        .Protect "4wink", DrawingObjects:=False, Contents:=True, Scenarios:=True
    End With
    Application.ScreenUpdating = True
End Sub
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Re: Help with Worksheet Deactivate

Try
Code: 
.Range("A150").End(xlUp).Offset(2).PasteSpecial xlPasteValues
 
Upvote 0
Re: Help with Worksheet Deactivate

In addition to the comments made by Fluff, I highlight other details:


Code: 
Private Sub Worksheet_Deactivate()
    Application.ScreenUpdating = False
[COLOR=#008000]    Dim lastRow As Long[/COLOR]
[COLOR=#008000]    With Sheet3[/COLOR]
        .Unprotect "4wink"
        .Range("A:E").Copy
        .Range("K:O").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Range("A3:E75").ClearContents
        .Range("G1:G75").Sort Key1:=[B][COLOR=#0000FF].[/COLOR][/B]Range("G1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Range("G1:G75").Copy
        .Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Range("I1:I75").Sort Key1:=[B][COLOR=#0000FF].[/COLOR][/B]Range("I1"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Range("I1:I75").Copy
[COLOR=#0000ff]        .Range("A150").End(xlUp).Offset(2).PasteSpecial Paste:=xlPasteValues[/COLOR]
        
        .Range("$C2") = "=IF(A2="""","""",INDEX($M:$M,MATCH($A2,$K:$K,0)))"
        .Range("$D2") = "=IF(B2="""","""",INDEX($N:$N,MATCH($A2,$K:$K,0)))"
        .Range("$E2") = "=IF(C2="""","""",INDEX($O:$O,MATCH($A2,$K:$K,0)))"
        lastRow = [B][COLOR=#0000FF].[/COLOR][/B]Range("A" & Rows.Count).End(xlUp).Row
        .Range("B2:E2").AutoFill Destination:=[SIZE=4][B][COLOR=#0000ff].[/COLOR][/B][/SIZE]Range("B2:E" & lastRow)
        .Range("C:E").Copy
        .Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Columns("C:E").Replace What:="#N/A", Replacement:=""
        .Columns("C:E").Replace What:="0", Replacement:=""
        .Columns("K:O").Delete
        .Protect "4wink", DrawingObjects:=False, Contents:=True, Scenarios:=True
[COLOR=#008000]    End With
    [/COLOR]Application.CutCopyMode = False
    [COLOR=#008000]Application[/COLOR].ScreenUpdating = True
End Sub
 
Upvote 0
Re: Help with Worksheet Deactivate

I'm still have the same problem. I'm getting a "Run-time error '1004' The cell is being protected. The code stops at line...
.Range("A3:E75").ClearContents
 
Upvote 0
Re: Help with Worksheet Deactivate

I'm using the following code on another sheet and am having to problems. I don't see why the problem would be occurring.

Code: 
Private Sub Worksheet_Deactivate()
    Application.ScreenUpdating = False
        With Sheet5
         .Unprotect "4wink"
         .Range("I1:I500").Sort Key1:=.Range("I2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
         .Range("D1:D500").Sort Key1:=.Range("D2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
         .Range("E2:E500").ClearContents
         .Range("E2") = "=IF(D2="""","""",COUNTIF(Galleys!$B$21:$AS$65,D2)+SUMPRODUCT((Galleys!$B$20:$AS$20=""LARGE"")*(Galleys!$B$21:$AS$65=D2)))"
         .Range("E2").AutoFill Destination:=.Range("E2:E" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    End With
    With Sheet2
        .CommandButton1.Caption = ThisWorkbook.Sheets("Disciplines").Range("$A2")
        .CommandButton3.Caption = ThisWorkbook.Sheets("Disciplines").Range("$A3")
        .CommandButton4.Caption = ThisWorkbook.Sheets("Disciplines").Range("$A4")
        .CommandButton2.Caption = ThisWorkbook.Sheets("Disciplines").Range("$A5")
        .CommandButton6.Caption = ThisWorkbook.Sheets("Disciplines").Range("$A6")
        .CommandButton7.Caption = ThisWorkbook.Sheets("Disciplines").Range("$A7")
        .CommandButton11.Caption = ThisWorkbook.Sheets("Disciplines").Range("$A8")
    End With
    Application.CutCopyMode = False
    
    Sheet5.Protect "4wink"
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Re: Help with Worksheet Deactivate

imback2nite said:
I'm still have the same problem. I'm getting a "Run-time error '1004' The cell is being protected. The code stops at line...
.Range("A3:E75").ClearContents
Click to expand...

You modified something in the code. Do you have another macro running on the sheet or on another sheet or in the book?
 
Upvote 0
Re: Help with Worksheet Deactivate

you can run the macros without protecting the sheet, just to rule out problems
 
Upvote 0
Re: Help with Worksheet Deactivate

I ran the code you suggested in a brand new workbook and still code the protection code error. Then I took out the lines
.Unprotect "4wink"
and
.Protect "4wink", DrawingObjects:=False, Contents:=True, Scenarios:=True
I tried the code then and it the sheet went into an endless loop. I had to ctrl-Alt Del to get it to stop. I'm totally lost as to why.
 
Upvote 0
Re: Help with Worksheet Deactivate

What happens if you replace
Code: 
With Sheet3
with
Code: 
With Me
 
Upvote 0
Re: Help with Worksheet Deactivate

Continuing with the original macro, try this, to avoid the loop.


Code: 
Private Sub Worksheet_Deactivate()
    Application.ScreenUpdating = False
    Dim lastRow As Long
    On Error GoTo AcEvents
[COLOR=#0000ff]    Application.EnableEvents = False[/COLOR]
    With Sheet3
        .Unprotect "4wink"
        .Range("A:E").Copy
        .Range("K:O").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Range("A3:E75").ClearContents
        .Range("G1:G75").Sort Key1:=.Range("G1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Range("G1:G75").Copy
        .Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Range("I1:I75").Sort Key1:=.Range("I1"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Range("I1:I75").Copy
        .Range("A150").End(xlUp).Offset(2).PasteSpecial Paste:=xlPasteValues
        
        .Range("$C2") = "=IF(A2="""","""",INDEX($M:$M,MATCH($A2,$K:$K,0)))"
        .Range("$D2") = "=IF(B2="""","""",INDEX($N:$N,MATCH($A2,$K:$K,0)))"
        .Range("$E2") = "=IF(C2="""","""",INDEX($O:$O,MATCH($A2,$K:$K,0)))"
        lastRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("B2:E2").AutoFill Destination:=.Range("B2:E" & lastRow)
        .Range("C:E").Copy
        .Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Columns("C:E").Replace What:="#N/A", Replacement:=""
        .Columns("C:E").Replace What:="0", Replacement:=""
        .Columns("K:O").Delete
        .Protect "4wink", DrawingObjects:=False, Contents:=True, Scenarios:=True
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
AcEvents:
[COLOR=#0000ff]    Application.EnableEvents = True[/COLOR]
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
280
willow1985
willow1985
K
  • Question Question
Increasing row before the macro runs again
Replies
1
Views
211
kbk
K
J
  • Solved
Continuous Copy and paste
2
Replies
10
Views
181
Joe4
Joe4
R
  • Solved
Retype Macro to run properly
2
Replies
11
Views
85
Alex Blakenburg
A
C
  • Question Question
How to automatically paste the data from one sheet to another using VBA
Replies
4
Views
235
Alex Blakenburg
A

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

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