Combine 2 VBA codes

January 2017



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


Published by aakai1056. Latest update on January 24, 2010 at 11:17 AM by aakai1056.
This document, titled "Combine 2 VBA codes," is available under the Creative Commons license. Any copy, reuse, or modification of the content should be sufficiently credited to CCM (ccm.net).