调用（运行）一个私人的Sub worksheet_Change（BYVAL目标作为范围）从公共子

我想知道是否有可能调用一个私人的Sub worksheet_Change（BYVAL目标作为范围）types的子从另一个公共子？ 我知道你不能真的“调用”子，但运行它，但是我尝试运行子似乎并没有工作。 这是我曾经试过的：

Sub AccessTransfer() Range("A1:F1").Select Selection.Copy Sheets("Sheet2").Select ActiveSheet.Paste ActiveCell.Offset(0, 6).Value = "Oven" Range("A65536").End(xlUp).Offset(1, 0).Select Run.Application "Private Sub Worksheet_Change(ByVal Target As Range)" Sheets("Sheet1").Select Application.CutCopyMode = False End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Application.CountIf(Range("A:A"), Target) > 1 Then MsgBox "Duplicate Entry", vbCritical, "Remove Data" Target.Value = "" End If Range("A65536").End(xlUp).Offset(1, 0).Select End Sub 

任何帮助或build议如何解决我的问题将不胜感激。

Answer 1

 With Sheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0) .Value = .Value End With 

会触发事件，但粘贴应该已经做了…

编辑 ：正如评论者指出，你的代码还有其他的问题：这应该是像你想要做的事情 –

 Sub AccessTransfer() Dim shtSrc As Worksheet, shtDest As Worksheet Dim v, c As Range Set shtSrc = ActiveSheet Set shtDest = ThisWorkbook.Sheets("Sheet2") v = shtSrc.Range("A1").Value 'value to check... If Application.CountIf(shtDest.Range("A:A"), v) > 0 Then MsgBox "Value '" & v & "' already exists!", vbCritical, "Can't Transfer!" Else 'OK to copy over... Set c = shtDest.Range("A65536").End(xlUp).Offset(1, 0) shtSrc.Range("A1:F1").Copy c c.Offset(0, 6).Value = "oven" End If Application.CutCopyMode = False End Sub 

Answer 2

你的代码有几个错误。

• 您可能会在Worksheet_Change中进行更改（例如Target.Value =“”），这将触发另一个事件。
• 您没有将目标分离到A列，也没有处理超过单个单元的Target。

Module1代码表：

 Sub AccessTransfer() With Worksheets("Sheet2") Worksheets("Sheet1").Range("A1:F1").Copy _ Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) 'Sheet2's Worksheet_Change has been triggered right here 'check if the action has been reversed If Not IsEmpty(.Cells(.Rows.Count, "A").End(xlUp)) Then 'turn off events for the Oven value write Application.EnableEvents = False .Cells(.Rows.Count, "A").End(xlUp).Offset(0, 6) = "Oven" 'turn events back on Application.EnableEvents = True End If End With End Sub 

Sheet2代码表：

 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A:A")) Is Nothing Then On Error GoTo bm_Safe_Exit Application.EnableEvents = False Dim c As Long, rngs As Range Set rngs = Intersect(Target, Range("A:A")) For c = rngs.Count To 1 Step -1 If Application.CountIf(Columns("A"), rngs(c)) > 1 Then MsgBox "Duplicate Entry in " & rngs(c).Address(0, 0), _ vbCritical, "Remove Data" rngs(c).EntireRow.Delete End If Next c End If bm_Safe_Exit: Application.EnableEvents = True End Sub