谁能帮我修改下这段代码

uqfyplj

我想实现以下功能：当表1中B列填入一个车牌号后，便会自动把：2014年车辆加油统计表、2014年车辆轮胎更换明细表、2014年车辆日常维修统计表，这三个文件夹里的工作薄内对应车牌的数据复制到表1里。（2014年车辆加油统计表在D盘、2014年车辆轮胎更换明细表在C盘、2014年车辆日常维修统计表在E盘）。
注：表1中“用油量”该行对应的数据为2014年车辆加油统计表中工作薄C列或E列的数据；表1中“油料费”该行对应的数据为2014年车辆加油统计表中工作薄D列或F列的数据；表1中“维修费”该行对应的数据为2014年车辆日常维修统计表中工作薄O列的数据；表1中“更换轮胎数”该行对应的数据为2014年车辆轮胎更换明细表中工作薄H列；表1中“轮胎费用”该行对应的数据为2014年车辆轮胎更换明细表中工作薄K列的数据。
注：想用VBA实现excel自动查找函数的功能。
附件： 调整.zip (323.4 KB, 下载次数: 2)

2015-1-14 16:27 上传

点击文件名下载附件

feiren228

1. Sub huizong()
   
2.     Dim Fso As Object, File As Object
   
3.     Dim cnn As Object, rs As Object, sql$, brr(1 To 5, 1 To 13)
   
4.     Set cnn = CreateObject("adodb.connection")
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     ch = [b4]
   
7.     '============提取加油数据===============================
   
8.     For Each File In Fso.GetFolder(ThisWorkbook.Path & "\2014年车辆加油统计表").Files
   
9.         If File.Name Like "*.xls" Then
   
10.             n = n + 1
    
11.             yf = Val(Split(Split(File.Name, "年")(1), "月")(0))
    
12.             If n = 1 Then cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & File
    
13.             sql = "select f3, f4, f5, f6 from [Excel 8.0;hdr=no;imex=1;Database=" & File & ";].[Sheet1$a4:g] where f2= '" & ch & "'"
    
14.             Set rs = cnn.Execute(sql)
    
15.             arr = rs.GetRows
    
16.             For i = 0 To UBound(arr) Step 2
    
17.                 If arr(i, 0) <> "Null" Then brr(1, yf) = arr(i, 0)
    
18.             Next
    
19.             For i = 1 To UBound(arr) Step 2
    
20.                 If arr(i, 0) <> "Null" Then brr(2, yf) = arr(i, 0)
    
21.             Next
    
22.         End If
    
23.     Next
    
24.     '=================提取维修费用============================
    
25.     For Each File In Fso.GetFolder(ThisWorkbook.Path & "\2014年车辆日常维修统计表").Files
    
26.         If File.Name Like "*.xls" Then
    
27.             yf = Val(Split(Split(File.Name, "年")(1), "月")(0))
    
28.             sql = "select f15 from [Excel 8.0;hdr=no;imex=1;Database=" & File & ";].[Sheet1$a4:o] where f3= '" & ch & "'"
    
29.             Set rs = cnn.Execute(sql)
    
30.             arr = rs.GetRows
    
31.             brr(3, yf) = arr(0, 0)
    
32.         End If
    
33.     Next
    
34.      '=================提取轮胎费用============================
    
35.     For Each File In Fso.GetFolder(ThisWorkbook.Path & "\2014年车辆轮胎更换明细表").Files
    
36.         If File.Name Like "*.xls" Then
    
37.             yf = Val(Split(Split(File.Name, "年")(1), "月")(0))
    
38.             sql = "select sum(f8),sum(f12) from [Excel 8.0;hdr=no;imex=1;Database=" & File & ";].[Sheet1$a4:m] where f2= '" & ch & "'"
    
39.             Set rs = cnn.Execute(sql)
    
40.             arr = rs.GetRows
    
41.             brr(4, yf) = arr(0, 0)
    
42.             brr(5, yf) = arr(1, 0)
    
43.         End If
    
44.     Next
    
45.     [d4].Resize(5, 13).ClearContents
    
46.     [d4].Resize(UBound(brr), UBound(brr, 2)) = brr
    
47. End Sub
    

复制代码

feiren228

附件》》》
调整test.rar (296.56 KB, 下载次数: 15)

2015-1-14 17:57 上传

点击文件名下载附件

uqfyplj

feiren228 发表于 2015-1-14 17:45
附件》》》

大虾你这个代码运行不了啊，提示错误！

feiren228

我这运行正常
'需引用Microsoft ActiveX Data Objects 2.0 Library以上

uqfyplj

feiren228 发表于 2015-1-14 20:21
我这运行正常
'需引用Microsoft ActiveX Data Objects 2.0 Library以上

谢谢大侠哈哈哈哈哈哈哈

LMY123

ADO+数组,FSO