如何把一个工作簿中的值填到多个工作簿的工作表中

zhaogang1960

yah760911 发表于 2012-5-14 08:23
版主，我有多个象“表”这样的文件夹，结果运行不了。可否改下可以执行多个文件夹的语句

1. Sub Macro1()
   
2.     Dim cnn As Object, cat As Object, tb1 As Object
   
3.     Dim SQL$, s$, t$, arr, i&, j&, m&, n&, arrf(), MyPath$, MyFile$
   
4.     arr = [a1].CurrentRegion
   
5.     Set cnn = CreateObject("adodb.connection")
   
6.     Set cat = CreateObject("ADOX.Catalog")
   
7.     MyPath = ThisWorkbook.Path & ""
   
8.     MyFile = Dir(MyPath, vbDirectory)
   
9.     Do While MyFile <> ""
   
10.         If MyFile <> "." And MyFile <> ".." Then
    
11.             If (GetAttr(MyPath & MyFile) And vbDirectory) = vbDirectory Then
    
12.                 m = m + 1
    
13.                 ReDim Preserve arrf(m)
    
14.                 arrf(m) = MyPath & MyFile & ""
    
15.             End If
    
16.         End If
    
17.         MyFile = Dir
    
18.     Loop
    
19.     For j = 1 To m
    
20.         MyFile = Dir(arrf(j) & "*.xls")
    
21.         While MyFile <> ""
    
22.             n = n + 1
    
23.             If n = 1 Then cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=excel 8.0;Data Source=" & arrf(j) & MyFile
    
24.             cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=No';Data Source=" & arrf(j) & MyFile
    
25.             For Each tb1 In cat.Tables
    
26.                 If tb1.Type = "TABLE" Then
    
27.                     s = Replace(tb1.Name, "'", "")
    
28.                     If Right(s, 1) = "$" Then
    
29.                         If n > 1 Then t = "[Excel 8.0;Database=" & arrf(j) & MyFile & "].[" & s & "]" Else t = "[" & s & "]"
    
30.                         For i = 2 To UBound(arr)
    
31.                             SQL = "update " & t & " set 子件規格='" & arr(i, 3) & "',基本用量=" & arr(i, 5) & ",子件顏色='" & arr(i, 6) & "'  where 子件編碼='" & arr(i, 1) & "'" '只取第一个条件
    
32.                             cnn.Execute SQL
    
33.                         Next
    
34.                     End If
    
35.                 End If
    
36.             Next
    
37.             MyFile = Dir()
    
38.         Wend
    
39.     Next
    
40.     cnn.Close
    
41.     Set cnn = Nothing
    
42.     Set cat = Nothing
    
43.     Set tb1 = Nothing
    
44.     MsgBox "更新完毕"
    
45. End Sub
    
46. 
    

复制代码

zhaogang1960

请看附件
测试.rar (48.11 KB, 下载次数: 15)

2012-5-14 12:40 上传

点击文件名下载附件

yah760911

{:soso_e179:}向您致敬！！！

zuiaidh2004

路过学习，赵版的热心让人感动

LMY123

For Each tb1 In cat.Tables