Combine 2 VBA codes

December 2016



Issue


How can I write these to codes into one code?

Code1)

Public Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 

Dim MyRange As Range 
Dim IntersectRange As Range 

Set MyRange = Range("d9:e38") 

Set IntersectRange = Intersect(Target, MyRange) 

On Error GoTo SkipIt 

If IntersectRange Is Nothing Then 
Exit Sub 

Else 

ActiveSheet.Unprotect 
Application.ScreenUpdating = False 

Target = Format(Now, "ttttt") 

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True 
ActiveSheet.EnableSelection = xllockedCells 

End If 

ActiveSheet.Unprotect 
Rows("1:3").Select 
Range("1:3,A4:E65536").Select 
Range("1:3,A4:E65536,G4:IV65536").Select 
Selection.Locked = False 
Selection.FormulaHidden = False 
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _ 
False 

ActiveCell.Offset(, 1).Select 

SkipIt: 
Exit Sub 


End Sub 



Code 2)

Public Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 
Const WS_RANGE As String = "A9:A39" '<== change to suit 

On Error GoTo ws_exit 
Application.EnableEvents = False 

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then 

With Target 

Me.Unprotect 
Target.Value = Format(Now, "ddddd") 
Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True 
Me.EnableSelection = xllockedCells 
Cancel = True 
End With 
End If 

ws_exit: 
Application.EnableEven
End Sub

Solution


Try this:

Public Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Const WS_RANGE As String = "A9:A39"
    Dim MyRange As Range
    Dim IntersectRange As Range
    Set MyRange = Range("d9:e38")
    Set IntersectRange = Intersect(Target, MyRange)
    On Error GoTo SkipIt
    If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
        With Target
            Me.Unprotect
            Target.Value = Format(Now, "ddddd")
            Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
            Me.EnableSelection = xllockedCells
            Cancel = True
        End With
    Else
        If IntersectRange Is Nothing Then
            Exit Sub
        Else
            ActiveSheet.Unprotect
            Application.ScreenUpdating = False
            Target = Format(Now, "ttttt")
            ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
            ActiveSheet.EnableSelection = xllockedCells
        End If
        ActiveSheet.Unprotect
        Rows("1:3").Select
        Range("1:3,A4:E65536").Select
        Range("1:3,A4:E65536,G4:IV65536").Select
        Selection.Locked = False
        Selection.FormulaHidden = False
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
        ActiveCell.Offset(, 1).Select
    End If
SkipIt:
    Application.EnableEvents = True
    Exit Sub
End Sub

Note


Thanks to Excelguru for this tip on the forum.

Related :

This document entitled « Combine 2 VBA codes » from CCM (ccm.net) is made available under the Creative Commons license. You can copy, modify copies of this page, under the conditions stipulated by the license, as this note appears clearly.