返回列表 上一主題 發帖

資料驗證能做多重選擇嗎

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
1# 跳轉到 »
發表於 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
複製代碼

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
2#
發表於 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
複製代碼

TOP

        靜思自在 : 人要知福、惜福、再造福。
返回列表 上一主題