- 帖子
- 2035
- 主題
- 24
- 精華
- 0
- 積分
- 2031
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office2010
- 閱讀權限
- 100
- 性別
- 男
- 註冊時間
- 2012-3-22
- 最後登錄
- 2024-2-1
|
回復 17# owen06
請你直接開啟 #1 的附件，然後將以下程式碼貼入到 Sheet2 的程式碼區再試試看 (完全複製過去)，
結果如何請回復告知，謝謝！ (我這邊無論是另行新增、或者是使用 #1 的附件都是OK的 )- Public ckCurr As Boolean
- Private Sub ComboBox1_Change() ' stillfish00 提供
- If ckCurr Then Exit Sub
-
- Application.EnableEvents = False
-
- ckCurr = False
- ComboBox1.Visible = False
- Range(ComboBox1.LinkedCell).Offset(, 2).Select
- Application.EnableEvents = True
- End Sub
- Private Sub CommandButton1_Click()
- If Me.ComboBox1.Visible Then ckCurr = True: Me.ComboBox1.Visible = False
-
- Range("A2:A25,C2:C25").Select
- Selection.ClearContents
- End Sub
- Private Sub Worksheet_SelectionChange(ByVal Target As Range)
- Dim StrVdFml As String
-
- ' If ckCurr Then Exit Sub
- On Error Resume Next
- StrVdFml = Replace(ActiveCell.Validation.Formula1, "=", "")
- ' ActiveCell.Validation.Formula1 ： "=Sheet1!$A$3:$A$20"
- ' ComboBox1.ListFillRange ： Sheet1!$A$3:$A$20
- ' Replace(ActiveCell.Validation.Formula1, "=", "") : "Sheet1!$A$3:$A$20"
- ' StrVdFml : "Sheet1!$A$3:$A$20"
- ActiveCell.Validation.InCellDropdown = False
- On Error GoTo 0
- If StrVdFml = "" Then
- If Me.ComboBox1.Visible Then Me.ComboBox1.Visible = False
- Else
- With Me.ComboBox1
- ' ComboBox1.progID =EMBED("Forms.ComboBox.1","")
- ' ComboBox1： ComboBox
- ' LinkedCell： $A$2
- ' ListFillRange ： Sheet1!$A$3:$A$20
- .Left = ActiveCell.Left
- .Top = ActiveCell.Top
- ' .Width = ActiveCell.Width + 140
- .Width = ActiveCell.Width
- ' .Height = ActiveCell.Height + 10
- .Height = ActiveCell.Height
- ' .Font.Size = 22
- .Font.Size = 12
- .LinkedCell = ActiveCell.Address ' "$A$2"
- .ListFillRange = StrVdFml ' "Sheet1!$A$3:$A$20"
- .Visible = 1 ' 顯示下拉符號
- .Object.SpecialEffect = 3
- '.Object.Font.Size = ActiveCell.Font.Size
- End With
- End If
-
- ckCurr = False
- End Sub
- Private Sub Worksheet_Change(ByVal Target As Range)
- ' Target.Font.ColorIndex = 5
-
- If Not Intersect(Target, Range("C2:C25")) Is Nothing Then
- If Target(1, 1) = 0 Then Exit Sub
- ckCurr = True
- ' MsgBox Target.Address
- Target.Offset(1, -2).Select
- End If
- End Sub
- Sub CellValidation() ' stillfish00 提供
- With Sheets("Sheet2").[A2:A25].Validation
- .Delete
- .Add Type:=xlValidateList, Formula1:="=Sheet1!$A$3:$A$20"
- End With
- End Sub
|
|
發表於 2013-11-5 08:56
| 
