Объединение двух или более частных сабов в одном листе

Question

Я хотел бы иметь две частные подпрограммы, как показано ниже (возможно, больше) на одном листе Каждый работает отдельно, но когда у меня есть оба, только первый работает. Не могли бы вы помочь мне.

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

    If Intersect(Target, Me.Range("f6:G19, j6:m19, f22:G35, j22:j35, L22:M35")) Is Nothing Then Exit Sub

    If Not Target.MergeCells Then
        If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    Else
        If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
    End If

    Cancel = True
    Dim Lastrow As Long
    Lastrow = Sheets("ShoppingCart").Cells(Rows.Count, "C").End(xlUp).Row + 1

    Target.Cells(1, 1).Copy Sheets("ShoppingCart").Cells(Lastrow, 3)



End Sub

и

Private Sub Worksheet_BeforeDoubleClick_B(ByVal Target As Range, Cancel As Boolean)

    If Intersect(Target, Me.Range("h24:h25, h8:h9")) Is Nothing Then Exit Sub

    If Not Target.MergeCells Then
        If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    Else
        If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
    End If


    Cancel = True
    Dim Lastrow As Long
    Lastrow = Sheets("ShoppingCart").Cells(Rows.Count, "C").End(xlUp).Row + 1

    Target.Cells(1, 1).Copy Sheets("ShoppingCart").Cells(Lastrow, 3)
    Sheets("ShoppingCart").Cells(Lastrow + 1, 3).Value = "148H3124"


End Sub

большое спасибо заранее.

Answer 1

Обработчики событий имеют указанные c имена, он не распознает вторую подпрограмму в качестве обработчика событий, он просто считает, что подпрограмма, имя которой имеет имя, похожее на первое. Вы можете либо переименовать оба, а затем создать новый подпункт события и вызвать их из него, либо объединить их в один подпункт.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    dblclick_a target, cancel
    dblclick_b target, cancel
end sub

Private Sub dblclick_a(ByVal Target As Range, Cancel As Boolean)

    If Intersect(Target, Me.Range("f6:G19, j6:m19, f22:G35, j22:j35, L22:M35")) Is Nothing Then Exit Sub

    If Not Target.MergeCells Then
        If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    Else
        If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
    End If

    Cancel = True
    Dim Lastrow As Long
    Lastrow = Sheets("ShoppingCart").Cells(Rows.Count, "C").End(xlUp).Row + 1

    Target.Cells(1, 1).Copy Sheets("ShoppingCart").Cells(Lastrow, 3)

End Sub

Private Sub dblclick_b(ByVal Target As Range, Cancel As Boolean)

    If Intersect(Target, Me.Range("h24:h25, h8:h9")) Is Nothing Then Exit Sub

    If Not Target.MergeCells Then
        If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    Else
        If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
    End If


    Cancel = True
    Dim Lastrow As Long
    Lastrow = Sheets("ShoppingCart").Cells(Rows.Count, "C").End(xlUp).Row + 1

    Target.Cells(1, 1).Copy Sheets("ShoppingCart").Cells(Lastrow, 3)
    Sheets("ShoppingCart").Cells(Lastrow + 1, 3).Value = "148H3124"


End Sub