新人求助！ 如何读取写入文件夹下文中的单元格的数据。。。

Ben_Yedder

读取某文件夹下面文件中单元格的数据，写入新表格中。。。自己编了一会，无法达到效果。。。。求各位大神帮帮忙！！！ 详细都在附件里面

rtian

1. Sub a()
   
2.     Dim path, p, r, n, i, conn, rst
   
3.     Dim arr(1 To 100, 1 To 14)     '可以用获取的文件数量来设置arr
   
4.     path = ThisWorkbook.path & ""
   
5.     f = Dir(path & "*.xlsx")
   
6.     r = 0
   
7.    
   
8.     Do While f <> ""
   
9.     n = 1
   
10.         Set conn = CreateObject("ADODB.Connection")
    
11.         conn.provider = "Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0"
    
12.         conn.Open "Data Source=" & path & f
    
13.         Set rst = CreateObject("ADODB.Recordset")
    
14.         Sql = "SELECT * FROM [FE CAP$]"
    
15.         rst.Open Sql, conn, 1, 3
    
16.         For i = 2 To 13
    
17.             rst.absoluteposition = i
    
18.             If i <> 4 Then arr(r + 1, n) = rst(1): n = n + 1
    
19.         Next
    
20.         rst.absoluteposition = 16
    
21.         For i = 0 To 2
    
22.             arr(r + 1, n) = rst(i)
    
23.             n = n + 1
    
24.         Next
    
25.         Set conn = Nothing
    
26.         r = r + 1
    
27.         f = Dir
    
28.     Loop
    
29. Sheet2.Range("b2").Resize(r, 14) = arr
    
30. End Sub
    

复制代码

rtian

1. Sub db()
   
2.     Dim path, fs, r, n, i, conn, rs, sql
   
3.     path = ThisWorkbook.path & ""
   
4.     Set fs = CreateObject("scripting.FileSystemObject").GetFolder(path).Files
   
5.     ReDim arr(0 To fs.Count, 0 To 14)
   
6.     r = 0
   
7.     For Each f In fs
   
8.         If f.Name Like "*.xlsx" Then
   
9.             n = 0: arr(r, n) = f.Name: n = n + 1
   
10.             Set conn = CreateObject("ADODB.Connection")
    
11.                 conn.provider = "Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0"
    
12.                 conn.Open "Data Source=" & path & f.Name
    
13.             Set rst = CreateObject("ADODB.Recordset")
    
14.                 sql = "select * from [Excel 12.0;HDR=NO;Database=" & path & f.Name & "].[$b3:d17]"
    
15.                 rst.Open sql, conn, 1, 3
    
16.             For i = 1 To 12
    
17.                 rst.absoluteposition = i
    
18.                 If i <> 3 Then arr(r, n) = rst(1): n = n + 1
    
19.             Next
    
20.             rst.absoluteposition = 15
    
21.             For i = 0 To 2
    
22.                arr(r, n) = rst(i)
    
23.                 n = n + 1
    
24.             Next
    
25.             Set conn = Nothing
    
26.             r = r + 1
    
27.         End If
    
28.     Next
    
29.     Sheet2.Range("a2").Resize(r, 15) = arr
    
30. End Sub
    
31. 
    

复制代码

LMY123

rst.absoluteposition = 15