2
我已经从Contextures网站调整了以下代码，该代码将组合框功能添加到包含数据验证的单元格中。尽管组合框在他们应该的位置显示出来，但我仍然面临着两个问题。 首先，我需要在“D4”单元中选择合并数据验证和组合框后的值之后，在工作簿中的“D4”单元的其他工作表上显示相同的值。不幸的是，在添加了组合框代码之后，Workbook_SheetChange代码停止工作。我认为这是因为它现在无法在数据验证/组合框单元中找到Target。 第二个问题是，即使应用了Application.ScreenUpdating，下面的Worksheet_SelectionChange代码也会导致屏幕闪烁。有什么办法摆脱它吗？ 我会很乐意为任何解决方案。单元格中的数据验证和组合框 - Workbook_SheetChange事件不起作用
编辑：
最后我设法找到解决办法首先发出自己。我完全忽略了Workbook_SheetChange事件并将其替换为ComboShtHeader_KeyDown和ComboShtHeader_LostFocus事件，这两个事件都放置在工作簿工作表中。这些宏可确保在按Tab，Enter或在“D4”单元外单击时，单元格的值在所有页面上都会更改。我将下面的两个代码放在某人面临类似问题的情况下。
尽管在Worksheet_SelectionChange代码中屏幕闪烁的其他问题仍然存在。解决方案仍然欢迎:-)
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