Board logo

標題: 資料驗證能做多重選擇嗎 [打印本頁]
作者: ClareWu    時間: 2014-3-17 10:03     標題: 資料驗證能做多重選擇嗎

請問各位前輩：

一般資料驗證，都只能從下拉清單選擇一項
如附件，我如果想在C2選擇安全帽跟安全鞋，資料驗證好像做不到
請問有比較適當的做法嗎？讓我可以從清單去選，又可以選擇多樣
謝謝大家
作者: yen956    時間: 2014-3-17 12:54

回復 1# ClareWu
試試看:
  1. Option Explicit
  2. '複製被勾選的 個人防護具
  3. Private Sub CommandButton1_Click()
  4.     Dim Rng, rngB As Range, endRow, Row1 As Integer
  5.    
  6.     '從 [A65536] 由下往上找, 直到找到 非空白格 為止的 Row(列數值)
  7.     endRow = [A65536].End(xlUp).Row
  8.    
  9.     '清除欄C
  10.     [C2:C65536] = ""
  11.    
  12.     '設定 rngB 的範圍
  13.     Set rngB = [B2].Resize(endRow, 1)
  14.    
  15.     '對於 rngB 的每一個成員 Rng 來說,
  16.     For Each Rng In rngB
  17.    
  18.         '如果 Rng 的右一格是 "v"
  19.         If Rng = "v" Then
  20.         
  21.             '非空白格 的 下一格 = 空白格
  22.             Row1 = [C65536].End(xlUp).Row + 1
  23.             
  24.             '欄C空白格 的值 = Rng 的左一格 的值
  25.             Cells(Row1, 3) = Rng.Offset(0, -1)
  26.         End If
  27.     Next
  28. End Sub

  30. '利用 欄B 勾選要複製的項目
  31. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  32.     Dim Rng, rngB As Range, endRow As Integer
  33.    
  34.     endRow = [A65536].End(xlUp).Row
  35.     Set rngB = [B1].Resize(endRow, 1)
  36.    
  37.     'Intersect(Target, rngB) 可將 SelectionChange
  38.     '所觸動的有效範圍限制在 rngB 中,
  39.     'rngB Is Nothing→表示 rngB 未被觸動
  40.     'Not Intersect(Target, rngB) Is Nothing
  41.     '→ 表示 rngB 被觸動了(負負得正)
  42.     If Not Intersect(Target, rngB) Is Nothing Then
  43.         If Target = "v" Then
  44.             Target = ""
  45.         Else
  46.             Target = "v"
  47.         End If
  48.     End If
  49. End Sub
複製代碼
作者: ClareWu    時間: 2014-3-17 18:00

謝謝回覆，請問是不是只能用VB才能達到這個功能？
作者: Hsieh    時間: 2014-3-18 09:51

回復 3# ClareWu
資料驗證就是為了避免輸入錯誤所設計
如果複選要存入同一儲存格就必須使用VBA輔助
如果依樓上動畫，那就直接一格點一次驗證來的直接
若是怕重複點選，就加入一個輔助欄位，排除已經被選過的資料做清單
[attach]17799[/attach]
[attach]17800[/attach]
作者: yen956    時間: 2014-3-19 18:06

回復 1# ClareWu
直接點選 要選取的項目 更方便
  1. Option Explicit
  2. '複製被勾選的 個人防護具
  3. Private Sub CommandButton1_Click()
  4.     Dim Rng, rngA As Range, endRow, Row1 As Integer
  5.    
  6.     '從 [A65536] 由下往上找, 直到找到 非空白格 為止的 Row(列數值)
  7.     endRow = [A65536].End(xlUp).Row
  8.    
  9.     '清除欄C
  10.     [C2:C65536] = ""
  11.    
  12.     '設定 rngA 的範圍
  13.     Set rngA = [A2].Resize(endRow, 1)
  14.    
  15.     '對於 rngB 的每一個成員 Rng 來說,
  16.     For Each Rng In rngA
  17.    
  18.         '如果 Rng 的右一格是 "v"
  19.         If Rng.Font.ColorIndex = 5 Then
  20.         
  21.             '非空白格 的 下一格 = 空白格
  22.             Row1 = [C65536].End(xlUp).Row + 1
  23.             
  24.             '欄C空白格 的值 = Rng 的左一格 的值
  25.             Cells(Row1, 3) = Rng
  26.         End If
  27.     Next
  28. End Sub

  30. '直接勾選要複製的項目
  31. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  32.     Dim Rng, rngA As Range, endRow As Integer
  33.    
  34.     endRow = [A65536].End(xlUp).Row
  35.     Set rngA = [A1].Resize(endRow, 1)
  36.    
  37.     'Intersect(Target, rngA) 可將 SelectionChange
  38.     '所觸動的有效範圍限制在 rngA 中,
  39.     If Not Intersect(Target, rngA) Is Nothing Then
  40.         If Target.Font.ColorIndex = 1 Then
  41.             Target.Font.ColorIndex = 5
  42.         Else
  43.             Target.Font.ColorIndex = 1
  44.         End If
  45.     End If
  46. End Sub
複製代碼
作者: ClareWu    時間: 2014-3-20 09:01

回復 4# Hsieh
謝大，我的VB還在非常非常低階階段，我有一個檔案感覺有點難度，我能請您幫我看看嗎？



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)