How do I use to similar subs in the same sheet?-CodePudding

I can use the two below subs individually and they work fine but I cannot figure out how to use them together on the same sheet. When I do I keep getting errors no matter how I rearrange.

FIRST SUB:

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect Password:="incoming"
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("b:b"), Target)
xOffsetColumn = -1
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).NumberFormat = "mm-dd-yyyy"
        Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
        Next
    Application.EnableEvents = True
    ActiveSheet.Protect Password:="incoming"
    End If
End Sub

SECOND SUB:

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect Password:="incoming"
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("g:g"), Target)
xOffsetColumn = 2
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).NumberFormat = "mm-dd-yyyy"
        Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
        Next
    Application.EnableEvents = True
    ActiveSheet.Protect Password:="incoming"
    End If
End Sub

CodePudding user response：

Use the Option Explicit on your modules.

You can have only one Worksheet_Change event on a worksheet.

Private Sub Worksheet_Change(ByVal Target As Range)
    ActiveSheet.Unprotect Password:="incoming"

    Dim WorkRng As Range
    Dim xOffsetColumn As Integer

    If Not Intersect(Application.ActiveSheet.Range("b:b"), Target) Is Nothing Then
        Set WorkRng = Intersect(Application.ActiveSheet.Range("b:b"), Target)
        xOffsetColumn = -1
        Call DoYourStuff(WorkRng, xOffsetColumn)
    End If
    
    If Not Intersect(Application.ActiveSheet.Range("g:g"), Target) Is Nothing Then
        Set WorkRng = Intersect(Application.ActiveSheet.Range("g:g"), Target)
        xOffsetColumn = 2
        Call DoYourStuff(WorkRng, xOffsetColumn)
    End If
    
    ActiveSheet.Protect Password:="incoming"
End Sub

Private Sub DoYourStuff(rg As Range, Col As Long)
    Dim Rng As Range
    
    Application.EnableEvents = False
    
    For Each Rng In rg
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, Col).Value = Now
            Rng.Offset(0, Col).NumberFormat = "mm-dd-yyyy"
        Else
            Rng.Offset(0, Col).ClearContents
        End If
    Next
    
    Application.EnableEvents = True
End Sub

CodePudding user response：

All subs (within a given scope) must have unique names. Hence, you can only have one event handler for any given worksheet event (i.e. only one sub named Worksheet_Change in a given worksheet module). I'm not exactly sure of your intent, but (as a best guess) the following code 're-arrangement' seems like what you're trying to do.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xOffsetColumn%, Rng As Range, WorkRng As Range
    
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="incoming"
    
    Set WorkRng = Intersect(ActiveSheet.Range("b:b"), Target)
    If Not WorkRng Is Nothing Then
        xOffsetColumn = -1
        
        For Each Rng In WorkRng.Cells
            If Rng <> "" Then
                Rng.Offset(0, xOffsetColumn).Value = Now
                Rng.Offset(0, xOffsetColumn).NumberFormat = "mm-dd-yyyy"
            Else
                Rng.Offset(0, xOffsetColumn).ClearContents
            End If
        Next
    End If

    Set WorkRng = Intersect(ActiveSheet.Range("g:g"), Target)
    If Not WorkRng Is Nothing Then
        xOffsetColumn = 2

        For Each Rng In WorkRng.Cells
            If Rng <> "" Then
                Rng.Offset(0, xOffsetColumn).Value = Now
                Rng.Offset(0, xOffsetColumn).NumberFormat = "mm-dd-yyyy"
            Else
                Rng.Offset(0, xOffsetColumn).ClearContents
            End If
            Next
    End If

    ActiveSheet.Protect Password:="incoming"
    Application.EnableEvents = True
End Sub

You can of course re-factor the above to simplify and/or make your code more elegant. The above though should address your core question.

CodePudding user response：

A Worksheet Change (Multiple Criteria)

Sheet Module e.g. Sheet1

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const FirstRow As Long = 2
    Const sColsList As String = "B,G"

    Dim sCols() As String: sCols = Split(sColsList, ",")
    
    Dim irg As Range
    Dim srg As Range
    Dim n As Long
    Dim rOffset As Long 
    
    For n = 0 To UBound(sCols)
        rOffset = FirstRow - 1
        With Me.Columns(sCols(n))
            Set srg = .Resize(.Rows.Count - rOffset).Offset(rOffset)
        End With
        Set irg = Intersect(srg, Target)
        If Not irg Is Nothing Then
            ProcessColumnRange irg, n
        End If
    Next n

End Sub

Standard Module e.g. Module1

Option Explicit

Sub ProcessColumnRange( _
        ByVal SourceRange As Range, _
        ByVal ColumnIndex As Long)
' Needs the 'RefCombinedRange' function.
    
    Const tsNumberFormat As String = "mm-dd-yyyy"
    Const dColsList As String = "A,I"
    Const Pwd As String = "incoming"
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error GoTo ClearError
    
    Dim ws As Worksheet: Set ws = SourceRange.Worksheet
    ws.Unprotect Pwd
    
    Dim dCols() As String: dCols = Split(dColsList, ",")
    Dim dCol As String: dCol = dCols(ColumnIndex)
    
    Dim sCell As Range ' Source Cell
    Dim dCell As Range ' Destionation Cell
    Dim dcrg As Range ' Destination Clear Range
    Dim dtsrg As Range ' Destination Time Stamp Range
    
    For Each sCell In SourceRange.Cells
        Set dCell = sCell.EntireRow.Columns(dCol)
        If IsEmpty(sCell) Then
            If Not IsEmpty(dCell) Then
                Set dcrg = RefCombinedRange(dcrg, dCell)
            End If
        Else
            Set dtsrg = RefCombinedRange(dtsrg, dCell)
        End If
    Next sCell
    
    If Not dcrg Is Nothing Then
        dcrg.ClearContents
    End If
    
    If Not dtsrg Is Nothing Then
        Dim TimeStamp As Date: TimeStamp = Now
        dtsrg.Value = TimeStamp
        dtsrg.NumberFormat = tsNumberFormat
    End If
    
    ws.Protect Pwd
    
SafeExit:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set RefCombinedRange = AddRange
    Else
        Set RefCombinedRange = Union(CombinedRange, AddRange)
    End If
End Function