Can anybody help me please. Why does Excel lock up when pasting data in a workbook which has the following code (below) in each worksheet?
It locks the whole application, not just the active workbook.
It also makes no difference whether or not the destination cell is in the range c4:n34 (as per the intersect command in the code).
Also it doesn't always lock it up, just 90% of the time. (tested on 2 different operating systems with different versions of Excel.)
thank you, Mike
------------------
Private Sub Worksheet_Change(ByVal Target As Range)
' values obtained from admin & help sheet - allows user to change options
On Error GoTo ohdear
Application.ScreenUpdating = False
If Target.Count > 1 Then Exit Sub 'if > 1 cell selected, exit
ActiveSheet.Unprotect
'
'dim WK entries
If Not (Intersect(Target, Range("d4:n34")) Is Nothing) And Target.Column <> 9 Then 'if <> range d4:n34, and <> col.9 do nothing
'
Dim cell As Range
Dim rng1 As Range
Set rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
If rng1 Is Nothing Then
Set rng1 = Range(Target.Address)
Else
Set rng1 = Union(Range(Target.Address), rng1)
End If
For Each cell In rng1
Select Case cell.Value
'
Case vbNullString 'default
With cell
.Font.Size = 10
.Font.Bold = False
.Font.ColorIndex = 1
.Interior.ColorIndex = xlNone
End With
'get values from admin & help sheet
Case Sheets("Admin & Help").Range("G4"), Sheets("Admin & Help").Range("G5"), Sheets("Admin & Help").Range("G6"), _
Sheets("Admin & Help").Range("G7"), Sheets("Admin & Help").Range("G8"), Sheets("Admin & Help").Range("G9"), _
Sheets("Admin & Help").Range("G10"), Sheets("Admin & Help").Range("G11"), Sheets("Admin & Help").Range("G12"), Sheets("Admin & Help").Range("G13")
With cell
.Font.Size = 8
.Font.FontStyle = "Bold"
.Font.ColorIndex = 48
.Interior.ColorIndex = 40
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
End With
Case Else 'default
With cell
.Font.Size = 10
.Font.Bold = False
.Font.ColorIndex = 1
.Interior.ColorIndex = xlNone
End With
End Select
Next
End If
'
'populate watches
If Not (Intersect(Target, Range("C4:N34")) Is Nothing) Then 'if not in range c4:n34 do nothing
'
If Target.Column = 3 Or Target.Column = 9 Then
If Target.Value = "A" Or Target.Value = "a" Then GoTo awatch 'A watch
If Target.Value = "B" Or Target.Value = "b" Then GoTo bwatch 'B watch
If Target.Value = vbNullString Then
With Target
.Offset(0, 1).ClearContents 'WM
.Offset(0, 2).ClearContents 'WO
.Offset(0, 3).ClearContents 'WO
.Offset(0, 4).ClearContents 'WA
.Offset(0, 5).ClearContents 'WA
End With: End If: End If
With ActiveSheet
.EnableSelection = xlUnlockedCells
.Protect
End With
GoTo ohdear
'
'get watch members from admin & help sheet
'
awatch: With Target
.Offset(0, 1).Value = Sheets("Admin & Help").Range("C4").Value 'WM
.Offset(0, 2).Value = Sheets("Admin & Help").Range("C5").Value 'WO
.Offset(0, 3).Value = Sheets("Admin & Help").Range("C6").Value 'WO
.Offset(0, 4).Value = Sheets("Admin & Help").Range("C7").Value 'WA
.Offset(0, 5).Value = Sheets("Admin & Help").Range("C8").Value 'WA
End With
With ActiveSheet
.EnableSelection = xlUnlockedCells
.Protect
End With: GoTo ohdear
bwatch: With Target
.Offset(0, 1).Value = Sheets("Admin & Help").Range("C12").Value 'WM
.Offset(0, 2).Value = Sheets("Admin & Help").Range("C13").Value 'WO
.Offset(0, 3).Value = Sheets("Admin & Help").Range("C14").Value 'WO
.Offset(0, 4).Value = Sheets("Admin & Help").Range("C15").Value 'WA
.Offset(0, 5).Value = Sheets("Admin & Help").Range("C16").Value 'WA
End With: End If
'error
ohdear:
With ActiveSheet
.EnableSelection = xlUnlockedCells
.Protect
End With: Exit Sub
End Sub
It locks the whole application, not just the active workbook.
It also makes no difference whether or not the destination cell is in the range c4:n34 (as per the intersect command in the code).
Also it doesn't always lock it up, just 90% of the time. (tested on 2 different operating systems with different versions of Excel.)
thank you, Mike
------------------
Private Sub Worksheet_Change(ByVal Target As Range)
' values obtained from admin & help sheet - allows user to change options
On Error GoTo ohdear
Application.ScreenUpdating = False
If Target.Count > 1 Then Exit Sub 'if > 1 cell selected, exit
ActiveSheet.Unprotect
'
'dim WK entries
If Not (Intersect(Target, Range("d4:n34")) Is Nothing) And Target.Column <> 9 Then 'if <> range d4:n34, and <> col.9 do nothing
'
Dim cell As Range
Dim rng1 As Range
Set rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
If rng1 Is Nothing Then
Set rng1 = Range(Target.Address)
Else
Set rng1 = Union(Range(Target.Address), rng1)
End If
For Each cell In rng1
Select Case cell.Value
'
Case vbNullString 'default
With cell
.Font.Size = 10
.Font.Bold = False
.Font.ColorIndex = 1
.Interior.ColorIndex = xlNone
End With
'get values from admin & help sheet
Case Sheets("Admin & Help").Range("G4"), Sheets("Admin & Help").Range("G5"), Sheets("Admin & Help").Range("G6"), _
Sheets("Admin & Help").Range("G7"), Sheets("Admin & Help").Range("G8"), Sheets("Admin & Help").Range("G9"), _
Sheets("Admin & Help").Range("G10"), Sheets("Admin & Help").Range("G11"), Sheets("Admin & Help").Range("G12"), Sheets("Admin & Help").Range("G13")
With cell
.Font.Size = 8
.Font.FontStyle = "Bold"
.Font.ColorIndex = 48
.Interior.ColorIndex = 40
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
End With
Case Else 'default
With cell
.Font.Size = 10
.Font.Bold = False
.Font.ColorIndex = 1
.Interior.ColorIndex = xlNone
End With
End Select
Next
End If
'
'populate watches
If Not (Intersect(Target, Range("C4:N34")) Is Nothing) Then 'if not in range c4:n34 do nothing
'
If Target.Column = 3 Or Target.Column = 9 Then
If Target.Value = "A" Or Target.Value = "a" Then GoTo awatch 'A watch
If Target.Value = "B" Or Target.Value = "b" Then GoTo bwatch 'B watch
If Target.Value = vbNullString Then
With Target
.Offset(0, 1).ClearContents 'WM
.Offset(0, 2).ClearContents 'WO
.Offset(0, 3).ClearContents 'WO
.Offset(0, 4).ClearContents 'WA
.Offset(0, 5).ClearContents 'WA
End With: End If: End If
With ActiveSheet
.EnableSelection = xlUnlockedCells
.Protect
End With
GoTo ohdear
'
'get watch members from admin & help sheet
'
awatch: With Target
.Offset(0, 1).Value = Sheets("Admin & Help").Range("C4").Value 'WM
.Offset(0, 2).Value = Sheets("Admin & Help").Range("C5").Value 'WO
.Offset(0, 3).Value = Sheets("Admin & Help").Range("C6").Value 'WO
.Offset(0, 4).Value = Sheets("Admin & Help").Range("C7").Value 'WA
.Offset(0, 5).Value = Sheets("Admin & Help").Range("C8").Value 'WA
End With
With ActiveSheet
.EnableSelection = xlUnlockedCells
.Protect
End With: GoTo ohdear
bwatch: With Target
.Offset(0, 1).Value = Sheets("Admin & Help").Range("C12").Value 'WM
.Offset(0, 2).Value = Sheets("Admin & Help").Range("C13").Value 'WO
.Offset(0, 3).Value = Sheets("Admin & Help").Range("C14").Value 'WO
.Offset(0, 4).Value = Sheets("Admin & Help").Range("C15").Value 'WA
.Offset(0, 5).Value = Sheets("Admin & Help").Range("C16").Value 'WA
End With: End If
'error
ohdear:
With ActiveSheet
.EnableSelection = xlUnlockedCells
.Protect
End With: Exit Sub
End Sub