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