数据validation和单元格中的combobox – Workbook_SheetChange事件不起作用
我已经从Contextures网站调整了以下代码，它将comboboxfunction添加到包含数据validation的单元格中。 尽pipecombobox应该显示出来，但我仍然面临着两个问题。 首先，在“D4”单元格中select合并数据validation和combobox之后，需要在该工作簿的“D4”单元格中显示相同的值。 不幸的是，在添加了combobox代码后，Workbook_SheetChange代码停止工作。 我认为这是因为它现在无法在数据validation/combobox中findTarget。 第二个问题是，即使应用了Application.ScreenUpdating，下面的Worksheet_SelectionChange代码也会导致屏幕闪烁。 有什么办法摆脱它？ 我会很乐意为任何解决scheme。
编辑：
最后，我设法find解决scheme，首先发布自己的问题。 我完全忽略了Workbook_SheetChange事件，并将其replace为ComboShtHeader_KeyDown和ComboShtHeader_LostFocus事件，这两个事件都放置在工作簿工作表中。 这些macros确保单元格的值在所有工作表上按Tab，Enter或在“D4”单元格外单击。 我正在把两个代码放在下面的案例，有人面临类似的问题。
Worksheet_SelectionChange代码中屏幕闪烁的另一个问题仍然存在。 解决scheme仍然是受欢迎的。:-)
Private Sub ComboShtHeader_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 'change "D4" cell value on all sheets on pressing TAB or ENTER Dim ws1 As Worksheet, ws As Worksheet Set ws1 = ActiveSheet Select Case KeyCode Case 9 'Tab ActiveCell.Offset(0, 1).Activate For Each ws In Worksheets If ws.Name <> ws1.Name Then ws.Range(ActiveCell.Offset(0, -3).Address).Value = ActiveCell.Offset(0, -3).Value End If Next ws Case 13 'Enter ActiveCell.Offset(1, 0).Activate For Each ws In Worksheets If ws.Name <> ws1.Name Then ws.Range(ActiveCell.Offset(-1, 0).Address).Value = ActiveCell.Offset(-1, 0).Value End If Next ws Case Else 'do nothing End Select End Sub Private Sub ComboShtHeader_LostFocus() 'change "D4" cell value on all sheets on click outside "D4" cell Dim ws1 As Worksheet, ws As Worksheet Set ws1 = ActiveSheet For Each ws In Worksheets If ws.Name <> ws1.Name Then ws.Range("D4").Value = ws1.Range("D4").Value End If Next ws End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim ws As Worksheet, ws2 As Worksheet Dim ComHead As OLEObject, ComBody As OLEObject Dim Str As String Application.ScreenUpdating = False On Error GoTo ErrHandler Set ws = ActiveSheet Set ws2 = Worksheets("lists") Set ComHead = ws.OLEObjects("ComboShtHeader") Set ComBody = ws.OLEObjects("ComboShtBody") On Error Resume Next If ComHead.Visible = True Then With ComHead .Top = 34.5 .Left = 120 .Width = 20 .Height = 15 .ListFillRange = "" .LinkedCell = "" .Visible = False .Value = "" End With End If On Error Resume Next If ComBody.Visible = True Then With ComBody .Top = 34.5 .Left = 146.75 .Width = 20 .Height = 15 .ListFillRange = "" .LinkedCell = "" .Visible = False .Value = "" End With End If On Error GoTo ErrHandler 'If the cell contains a data validation list If Target.Validation.Type = 3 Then If Target.Address = ws.Range("D4:F4").Address Then If Target.Count > 3 Then GoTo ExitHandler Application.EnableEvents = False 'Get the data validation formula Str = Target.Validation.Formula1 Str = Right(Str, Len(Str) - 1) With ComHead 'Show the combobox with the validation list .Visible = True .Left = Target.Left .Top = Target.Top .Width = Target.Width + 15 .Height = Target.Height .ListFillRange = ws2.Range(Str).Address(external:=True) .LinkedCell = Target.Address End With ComHead.Activate 'Open the dropdown list automatically Me.ComboShtHeader.DropDown Else If Target.Count > 1 Then GoTo ExitHandler Application.EnableEvents = False 'Get the data validation formula Str = Target.Validation.Formula1 Str = Right(Str, Len(Str) - 1) With ComBody 'Show the combobox with the validation list .Visible = True .Left = Target.Left .Top = Target.Top .Width = Target.Width + 15 .Height = Target.Height .ListFillRange = ws2.Range(Str).Address(external:=True) .LinkedCell = Target.Address End With ComBody.Activate 'Open the dropdown list automatically Me.ComboShtBody.DropDown End If End If ExitHandler: Application.ScreenUpdating = True Application.EnableEvents = True Exit Sub ErrHandler: Resume ExitHandler End Sub
第二个代码放置在ThisWorkbook模块中，目前不工作：
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim wb1 As Workbook Dim ws1 As Worksheet, ws As Worksheet With Application .EnableEvents = False .ScreenUpdating = False End With Set wb1 = ThisWorkbook Set ws1 = Sh On Error GoTo LetsContinue 'This should change "D4" value on all sheets, but does not work after combobox feature was added to the sheets. If Not Intersect(Target, ws1.Range("D4")) Is Nothing Then MsgBox Target.Address 'returns nothing For Each ws In wb1.Worksheets If Target.Value <> ws.Range(Target.Address).Value Then ws.Range(Target.Address).Value = Target.Value End If Next ws Else GoTo LetsContinue End If LetsContinue: With Application .EnableEvents = True .ScreenUpdating = True End With End Sub
实际上，当我从Excel 2007移到2013版本时，第二个考虑到屏幕闪烁的问题就解决了。 这似乎是在旧版本中的某种错误。