Worksheet_change事件-從下拉列表中選擇時更改所有工作表上的單元格值

Question

我想知道是否有人可以建議以下代碼。 直到我將下拉列表添加到“ D4”單元格（更確切地說，它們是合並的單元格“ D4：F4”）之前，它一直運行良好。 D4單元格中的這些下拉列表位於工作簿的所有工作表上，但“列表”工作表除外，並保存相同的數據。 這些源數據在工作表“列表”上的命名表中，並使用INDIRECT函數進行引用。 我想要實現的是，如果我從任何工作表的下拉列表中選擇一項，則“ D4”單元格值會在其他工作表上自動更改。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim wb1 As Workbook
Dim ws1 As Worksheet

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set wb1 = ThisWorkbook
Set ws1 = wb1.ActiveSheet

If Target.Cells.Count > 1 Then GoTo LetsContinue

'Change cell value on all sheets except for sheet "lists"
If Not Intersect(Target, ws1.Range("D4")) Is Nothing Then
    For Each ws In wb1.Worksheets
        If ws.Name <> "lists" Then
            If Target.Value <> ws.Range(Target.Address).Value Then
            ws.Range(Target.Address).Value = Target.Value
        End If
    End If
    Next ws
Else
    GoTo LetsContinue
End If

LetsContinue:
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

Answer 1

嘗試將代碼作為Worbook_SheetChange事件放入Workbook模塊中，而不要使用工作表事件：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Dim wb1 As Workbook
Dim ws1 As Worksheet

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set wb1 = ThisWorkbook
Set ws1 = Sh

If Target.Cells.Count > 1 Then GoTo LetsContinue

'Change cell value on all sheets except for sheet "lists"
If Not Intersect(Target, ws1.Range("D4")) Is Nothing Then
    For Each ws In wb1.Worksheets
        If ws.Name <> "Lists" Then
            If Target.Value <> ws.Range(Target.Address).Value Then
                ws.Range(Target.Address).Value = Target.Value
            End If
        End If
    Next ws
Else
    GoTo LetsContinue
End If

LetsContinue:
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

像這樣，您的代碼將適用於工作簿的任何工作表。