不同文件夹不同工作薄数据有效性的问题

aman1516

数据有效性一直受限制于本表，或通过名称引用于不同的表，但不从不同文件夹的其它工作薄中引用数据源。
请问能否用VBA 或其它方法可以实现呢？
请老师帮忙解决下附件中的问题。

yanjie

呵呵，我知道怎么做！
用ado或者MS Query的参数查询来操作！

aman1516

噢，版主，求求您了，帮帮忙，帮我做一个吧！
授人以渔，也应该详细一点点呀。

zhaogang1960

试试：
Dim arr, d As Object
Private Sub Workbook_Open()
    Dim cnn As Object
    Dim SQL As String, i&
    Set cnn = CreateObject("adodb.connection")
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & ThisWorkbook.Path & "\装配产能.xls" '请自己修改路径
    SQL = "Select * from [Sheet1$a2:f65536] where f2 is not null"
    arr = cnn.Execute(SQL).GetRows
    cnn.Close
    Set cnn = Nothing
    Set d = CreateObject("scripting.dictionary")
    For i = 0 To UBound(arr, 2)
        d(arr(1, i)) = i
    Next
    With Sheet1
        .[iv:iv] = ""
        .[iv1].Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
        With .[b2:b65536].Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & Sheet1.[iv1].Resize(d.Count).Address
        End With
    End With
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name <> "Sheet1" Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, [b2:b65536]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    If d Is Nothing Then Workbook_Open
    Target.Offset(, -1) = arr(0, d(Target.Value))
    Target.Offset(, 2) = arr(3, d(Target.Value))
    Target.Offset(, 3) = arr(5, d(Target.Value))
End Sub
不同文件夹不同工作薄数据有效性问题.rar (21.26 KB, 下载次数: 197)

2010-4-25 01:12 上传

点击文件名下载附件

aman1516

谢谢Zhaogang1960，这正是我想达到的，VBA太强大了，一定要好好学习。

您的一滴水，对于一个干渴的人无疑是一捧甘甜的泉水！

予人玫瑰，手有余香。

lqb9886

zhaogang1960 发表于 2010-4-25 01:12
试试：
Dim arr, d As Object
Private Sub Workbook_Open()

请问2010版本的excel这样调用不行的，提示 ，应该如何修改呢？谢谢

zhaogang1960

lqb9886 发表于 2011-11-27 11:10
请问2010版本的excel这样调用不行的，提示，应该如何修改呢？谢谢

1. Dim arr, d As Object
   
2. Private Sub Workbook_Open()
   
3.     Dim cnn As Object
   
4.     Dim SQL As String, i&
   
5.     Set cnn = CreateObject("adodb.connection")
   
6.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & ThisWorkbook.Path & "\装配产能.xlsx" '请自己修改路径
   
7.     SQL = "Select * from [Sheet1$a2:f" & Rows.Count & "] where f2 is not null"
   
8.     arr = cnn.Execute(SQL).GetRows
   
9.     cnn.Close
   
10.     Set cnn = Nothing
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     For i = 0 To UBound(arr, 2)
    
13.         d(arr(1, i)) = i
    
14.     Next
    
15.     With Sheet1
    
16.         .[iv:iv] = ""
    
17.         .[iv1].Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
    
18.         With .Range("b2:b" & Rows.Count).Validation
    
19.             .Delete
    
20.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & Sheet1.[iv1].Resize(d.Count).Address
    
21.         End With
    
22.     End With
    
23. End Sub
    
24. 
    
25. Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
26.     If Sh.Name <> "Sheet1" Then Exit Sub
    
27.     If Target.Count > 1 Then Exit Sub
    
28.     If Intersect(Target, Range("b2:b" & Rows.Count)) Is Nothing Then Exit Sub
    
29.     If Target = "" Then Exit Sub
    
30.     If d Is Nothing Then Workbook_Open
    
31.     Target.Offset(, -1) = arr(0, d(Target.Value))
    
32.     Target.Offset(, 2) = arr(3, d(Target.Value))
    
33.     Target.Offset(, 3) = arr(5, d(Target.Value))
    
34. End Sub
    

复制代码

LMY123

ADO+字典， d(arr(1, i)) = i