Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1951|回复: 3

[已解决]关于数据有效性的问题

[复制链接]
发表于 2011-10-23 10:00 | 显示全部楼层 |阅读模式
本帖最后由 雪上人家 于 2011-10-23 10:00 编辑

想在B5:B10用VBA产生数据有效性的序列,不在错在哪,在论坛和百度上找了很久,也没办法解决。有高手能解决吗?
最佳答案
2011-10-23 10:43
本帖最后由 zjdh 于 2011-10-23 10:47 编辑

  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     ActiveSheet.Unprotect
  3.     If Not Application.Intersect(Target, Range("$B$5:$B$10")) Is Nothing Then
  4.         Dim conn, Arr, i&, myPath$, bb$
  5.         myPath = ThisWorkbook.Path & "\源数据\生成序列的源数据.xls"
  6.         Set conn = CreateObject("adodb.connection")    '定义对象
  7.         conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & myPath
  8.         Arr = conn.Execute("select  * from [生成序列的源数据$]").getrows
  9.         For i = 3 To UBound(Arr, 2)
  10.             If Arr(0, i) <> "" Then bb = bb & Arr(0, i) & ","
  11.         Next
  12.         bb = Left(bb, Len(bb) - 1)    '去除最后一个多余的逗号
  13.         With Target.Validation
  14.             .Delete
  15.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  16.                  Operator:=xlBetween, Formula1:=bb    '增加新的数据有效性
  17.         End With
  18.         Set conn = Nothing
  19.     End If
  20.     ActiveSheet.Protect
  21. End Sub
复制代码

VBA数据有效性序列新问题.rar

14.18 KB, 下载次数: 15

 楼主| 发表于 2011-10-23 11:37 | 显示全部楼层
谢谢zjdh 老师,可以了。真是太感谢了。
回复

使用道具 举报

发表于 2011-10-23 10:43 | 显示全部楼层    本楼为最佳答案   
本帖最后由 zjdh 于 2011-10-23 10:47 编辑

  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     ActiveSheet.Unprotect
  3.     If Not Application.Intersect(Target, Range("$B$5:$B$10")) Is Nothing Then
  4.         Dim conn, Arr, i&, myPath$, bb$
  5.         myPath = ThisWorkbook.Path & "\源数据\生成序列的源数据.xls"
  6.         Set conn = CreateObject("adodb.connection")    '定义对象
  7.         conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & myPath
  8.         Arr = conn.Execute("select  * from [生成序列的源数据$]").getrows
  9.         For i = 3 To UBound(Arr, 2)
  10.             If Arr(0, i) <> "" Then bb = bb & Arr(0, i) & ","
  11.         Next
  12.         bb = Left(bb, Len(bb) - 1)    '去除最后一个多余的逗号
  13.         With Target.Validation
  14.             .Delete
  15.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  16.                  Operator:=xlBetween, Formula1:=bb    '增加新的数据有效性
  17.         End With
  18.         Set conn = Nothing
  19.     End If
  20.     ActiveSheet.Protect
  21. End Sub
复制代码
回复

使用道具 举报

发表于 2011-10-23 12:52 | 显示全部楼层
本帖最后由 zjdh 于 2011-10-23 12:53 编辑

你那C列可以用以下宏实现自动填写:

  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim conn, I
  3.     If Not Application.Intersect(Target, Range("$B$5:$B$10")) Is Nothing Then
  4.         myPath = ThisWorkbook.Path & "\源数据\生成序列的源数据.xls"
  5.         Set conn = CreateObject("adodb.connection")
  6.         conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & myPath
  7.         Arr = conn.Execute("select  * from [生成序列的源数据$]").getrows
  8.         For I = 1 To UBound(Arr, 2)
  9.             If Arr(0, I) = Target Then Target.Offset(0, 1) = Arr(1, I): Exit For
  10.         Next
  11.     End If
  12. End Sub
复制代码
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 02:36 , Processed in 0.525523 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表