统计VBA学习小组正式组第八课（第九讲）的积分帖之作业上交贴（第10周）

ybchxj2010

前面发的附件有个小问题，不能识别小写输入；现更正后上传

happym8888

C17:Happym8888
第8课作业题C17-Happym8888.rar (10.5 KB, 下载次数: 6)

2012-3-3 17:14 上传

点击文件名下载附件

windimi007

D组学委:windimi007前来叫作业！
这次正好借用兰版的这个题练习一下在VBA中使用SQL，有什么不当之处还望兰版指导，谢谢。

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     On Error Resume Next
   
4.     If Target.Address(0, 0) = "E5" Then
   
5.         Dim AdoConn As Object
   
6.         Dim AdoRst As Object
   
7.         Dim StrConn As String
   
8.         Dim StrSql As String
   
9.         Dim arr
   
10.         Set AdoConn = CreateObject("Adodb.connection")
    
11.         Set AdoRst = CreateObject("Adodb.RecordSet")
    
12.         StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    
13.                   "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
14.         StrSql = "SELECT 单价 FROM [Database=" & ThisWorkbook.Path & "\价格表.xls;Excel 12.0].[Sheet1$] WHERE STRCOMP(产品名称,""" & Target.Value & """,0)=0"
    
15.         AdoConn.Open StrConn
    
16.         Set AdoRst = AdoConn.Execute(StrSql)
    
17.         arr = AdoRst.GetRows
    
18.         If Err.Number = 3021 Then
    
19.             Cells(7, "E") = "查找不到"
    
20.         Else
    
21.             If UBound(arr, 2) = 0 Then
    
22.                 Cells(7, "E") = arr(0, 0)
    
23.             Else
    
24.                 Cells(7, "E") = Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(arr)), ",")
    
25.             End If
    
26.         End If
    
27.         AdoRst.Close
    
28.         AdoConn.Close
    
29.         Set AdoRst = Nothing
    
30.         Set AdoConn = Nothing
    
31.     End If
    
32. End Sub

复制代码

ykymj

上交作业，祥见附件

水上漂123

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim jgb As Workbook
If Sh.Name = "Sheet1" And Target.Address = "$E$5" Then
Set jgb = Workbooks.Open(ThisWorkbook.Path & "价格表.xls")
Dim x As Integer
Dim m
For x = 2 To 7
If Target.Value = Cells(x, 1) Then
m = Cells(x, 2)
Target.Offset(2, 0).Value = m
MsgBox (m)
Exit For
Else
Target.Offset(2, 0).Value = "查找不到"
End If
Next x
jgb.Close
End If

LIYEHUAOK

结果虽然出来了感觉效果不是很好，还望老师指点指点

byhdch

第8课作业题：A09byhdch.rar (16.94 KB, 下载次数: 14)

2012-3-5 18:14 上传

点击文件名下载附件

hactnet

交下作业，第八课第9讲

chrissha

C组10： CHRISSHA
第8课作业题查找.rar (11.92 KB, 下载次数: 15)

2012-3-4 20:03 上传

点击文件名下载附件

yijundanny

游客，如果您要查看本帖隐藏内容请回复