编写自定义函数-跨工作薄取值

barryro

编写自定义函数，满足型号规格条件时，在数据源中取相应值。

microyip

1. Function 目标值(ByVal vModel As Variant, ByVal vType As Variant) As Variant
   
2. '用法：在单元格D2内录入   =目标值(B2,C2)
   
3. 'vModle,型号单元格的值；vType，规格单元格的值
   
4.     Dim sModel As String, sType As String
   
5.     Dim oConn As Object, oRS As Object
   
6.     Dim sSelect As String
   
7.    
   
8.     sModel = Trim(UCase(vModel))
   
9.     sType = Trim(vType)
   
10.     If Not (sModel = "YJV" Or sModel = "ZR-YJV") Then
    
11.         目标值 = "错误参数！"
    
12.         Exit Function
    
13.     End If
    
14.    
    
15.     Set oConn = CreateObject("Adodb.Connection")
    
16.     If Val(Application.Version) < 12 Then
    
17.         oConn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='Excel 8.0;IMEX=0;HDR=NO';Data Source=" & ThisWorkbook.Path & "\数据源.xlsx"
    
18.     Else
    
19.         oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;IMEX=0;HDR=NO';Data Source=" & ThisWorkbook.Path & "\数据源.xlsx"
    
20.     End If
    
21.    
    
22.     If sModel = "YJV" Then
    
23.         sSelect = "Select [F2] From [Sheet1$] Where [F1]='" & sType & "'"
    
24.     Else
    
25.         sSelect = "Select [F3] From [Sheet1$] Where [F1]='" & sType & "'"
    
26.     End If
    
27.     Set oRS = CreateObject("Adodb.RecordSet")
    
28.     On Error GoTo CloseRead
    
29.     Set oRS = oConn.Execute(sSelect)
    
30.     If oRS.State = 1 Then
    
31.         If Not (oRS.EOF And oRS.BOF) Then vModel = oRS.GetRows
    
32.     End If
    
33.     oRS.Close
    
34. CloseRead:
    
35.     On Error GoTo 0
    
36.     Set oRS = Nothing
    
37.     oConn.Close
    
38.     Set oConn = Nothing
    
39.     If IsArray(vModel) Then
    
40.         If IsNull(vModel(0, 0)) Then
    
41.             目标值 = "空值"
    
42.         Else
    
43.             目标值 = vModel(0, 0)
    
44.         End If
    
45.     Else
    
46.         目标值 = "没有记录"
    
47.     End If
    
48. End Function

复制代码

microyip

附上附件以供参考

wwz851025

microyip 发表于 2018-8-12 13:38
附上附件以供参考

麻烦老师移步到这里http://club.excelhome.net/thread-1430279-1-1.html
请帮我看看这个问题怎么处理。
多个列表框实现单选和多选功能。先谢谢了！