求助多选下拉VBA

chengjun197

求助大神，请在“人员基本信息”工作表中，将有害因素列按照“高温、噪声、其它粉尘、一氧化碳、电焊烟尘、锰及其化合物、紫外线”；设置多选下拉菜单；防护措施列按照“防暑降温药品、耳塞、防尘口罩、煤气报警仪、电焊面罩”设置多选下拉菜单，表格样式不变，其它列不变。VBA不太会用呢

chengjun197

大神在哪里 大神在哪里

孙森峰

是不是只要设置有效性列表就可以了？

micch

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim rngDV As Range
   
3.     Dim oldVal As String
   
4.     Dim newVal As String
   
5.     Dim strVal As String
   
6.     Dim i As Integer
   
7.     Set rngDV = Me.Range("D5")
   
8.     If Intersect(Target, rngDV) Is Nothing Then Exit Sub
   
9.     If rngDV.Value = "" Then Exit Sub
   
10.     Application.EnableEvents = False
    
11.     newVal = Target.Value
    
12.     Application.Undo
    
13.     oldVal = Target.Value
    
14.     Target.Value = newVal
    
15.     If oldVal = "" Then
    
16.         GoTo exitHandler
    
17.     End If
    
18.     On Error Resume Next
    
19.     If InStr(1, oldVal, newVal) = 0 Then
    
20.         strVal = oldVal & "|" & newVal
    
21.     Else
    
22.         i = InStr(1, oldVal, newVal)
    
23.         If i = 1 Then
    
24.             strVal = Right(oldVal, Len(oldVal) - Len(newVal) - 1)
    
25.         Else
    
26.             strVal = Left(oldVal, i - 1) & Mid(oldVal, i + Len(newVal) + 1)
    
27.         End If
    
28.     End If
    
29.     Target.Value = Trim(strVal)
    
30. exitHandler:
    
31.     Application.EnableEvents = True
    
32. End Sub
    
33. Sub SetupDataValidation()
    
34.     Dim ws As Worksheet
    
35.     Dim rng As Range
    
36.     Dim dv As Validation
    
37.     Set ws = ActiveSheet
    
38.     Set rng = ws.Range("D5")
    
39.     rng.Validation.Delete
    
40.     Set dv = rng.Validation
    
41.     With dv
    
42.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="苹果,香蕉,橙子,葡萄,西瓜"
    
43.         .IgnoreBlank = True
    
44.         .InCellDropdown = True
    
45.         .ShowInput = True
    
46.         .ShowError = True
    
47.     End With
    
48. End Sub
    

复制代码