Hsieh

回復 1# bridetobe
在驗證所在的工作表模組

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim Rng As Range, newitem$, newlist$
   
3. If Target.Address Like "$B$*" Then '改變的儲存格為B欄
   
4.     If Target(1) = "新增" Then '若選擇新增
   
5.     Application.EnableEvents = False '關閉觸發事件程序
   
6.     newitem = InputBox("請輸入新增項目") '新增項目
   
7.        With 工作表2
   
8.        .[A1].End(xlDown).Offset(1) = newitem '清單底部新增項目
   
9.        newlist = "=" & .Range(.[A1], .[A1].End(xlDown)).Address(, , , 1) '新清單位址
   
10.        End With
    
11.      Set Rng = Target.SpecialCells(xlCellTypeSameValidation) '相同驗證儲存格
    
12.      With Rng.Validation
    
13.      .Delete '刪除驗證
    
14.      .Add xlValidateList, , , newlist '加入驗證
    
15.      End With
    
16.       Target = newitem '儲存格改為新值
    
17.     Application.EnableEvents = True '開啟觸發事件程序
    
18.      End If
    
19. End If
    
20. End Sub

複製代碼

Hsieh

回復 3# bridetobe

試試看是否符合?

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim A As Range
   
3. If Target.Column <> 2 Then Exit Sub
   
4. With 工作表2
   
5.   ThisWorkbook.Names.Add "清單", "=OFFSET(" & .Name & "!$A$1,,,COUNTA(" & .Name & "!$A:$A))" '建立動態範圍名稱做為清單
   
6.   Set A = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) '清單下一格
   
7. End With
   
8. With Target
   
9. Select Case .Value
   
10. Case "新增"
    
11.    newitem = InputBox("輸入新增項目")
    
12.    If IsError(Application.Match(newitem, [清單], 0)) Then A.Value = newitem Else MsgBox newitem & "已在清單內": Exit Sub
    
13.    With .EntireColumn.Validation
    
14.    .Delete
    
15.    .Add xlValidateList, , Formula1:="=" & [清單].Address(, , , 1)
    
16.    End With
    
17.    Target = newitem
    
18. Case "刪除"
    
19.    delitem = InputBox("輸入刪除項目")
    
20.    Set A = [清單].Find(delitem, lookat:=xlWhole)
    
21.    If A Is Nothing Then
    
22.       MsgBox delitem & "未在清單內"
    
23.       Else
    
24.       A.Delete xlShiftUp
    
25.    With .EntireColumn.Validation
    
26.    .Delete
    
27.    .Add xlValidateList, , Formula1:="=" & [清單].Address(, , , 1)
    
28.    End With
    
29.    End If
    
30. End Select
    
31. End With
    
32. End Sub

複製代碼

Hsieh

回復 5# bridetobe

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim A As Range
   
3. If Target.Column <> 2 Then Exit Sub
   
4. With 工作表2
   
5. ThisWorkbook.Names.Add "清單", "=OFFSET(" & .Name & "!$A$1,,,COUNTA(" & .Name & "!$A:$A),)"
   
6. With Range("B:B").Validation
   
7.    .Delete
   
8.    .Add xlValidateList, , , "=清單"
   
9. End With
   
10. Select Case Target.Value
    
11. Case "新增"
    
12. newitem = InputBox("輸入新增項目")
    
13. If Application.CountIf([清單], newitem) = 0 Then
    
14.    Set A = .Columns("A:A").Find("新增", lookat:=xlWhole)
    
15.    A.Insert xlShiftDown
    
16.    A.Offset(-1) = newitem
    
17.    Target = newitem
    
18. Else
    
19.    MsgBox "項目已存在清單內"
    
20. End If
    
21. Case "刪除"
    
22. delitem = InputBox("輸入刪除項目")
    
23. Set A = .Columns("A:A").Find(delitem, lookat:=xlWhole)
    
24. If A Is Nothing Then
    
25.    MsgBox delitem & "不存在清單內"
    
26.    Else
    
27.    A.Delete xlShiftUp
    
28. End If
    
29. Case "修改"
    
30. chitem = InputBox("輸入修改項目")
    
31. Set A = .Columns("A:A").Find(chitem, lookat:=xlWhole)
    
32. If A Is Nothing Then
    
33.    MsgBox chitem & "不存在清單內"
    
34.    Else
    
35.    A.Value = InputBox("輸入更正項目", , chitem)
    
36.    Target = A
    
37. End If
    
38. End Select
    
39. End With
    
40. With Range("B:B").Validation
    
41.    .Modify xlValidateList, , , "=清單"
    
42. End With
    
43. End Sub

複製代碼