[已解决]是用ADO 导入数据。

顺⑦.zì繎。

说明都在附件中了

最佳答案

月排行榜 / 总排行榜

xdragon

2014-9-25 13:18

Sub test()
   Dim fn$, pth$, cnt%, fns()
   Dim conn As Object, rst As Object, sql$, re$(), i&
   '变量说明：fn=文件名称，pth=文件路径，cnt=汇总文件的计数；结果数组的计数
   '变量说明：fns=存放局部sql语句，sql=最终执行的sql语句，re$()=最终结果数组（如果不需要全部为文本类型可取消定义文本）
   '变量说明：conn=ado连接数据库对象，rst=ado数据集对象，i=用于循环数据集中每列的存放记录
   pth = ThisWorkbook.Path & "\"
   fn = Dir(pth & "*.xls*")
'-----------------------------------------------------------------------------------------
   Do '循环读取工作表名并存放局部的sql语句到fns数组中
       If fn <> ThisWorkbook.Name Then
           cnt = cnt + 1
           ReDim Preserve fns(1 To cnt)
           fns(cnt) = "select * from [" & pth & fn & "].[销售明细$a2:i] where len(编号)"  '此处如果文件可用区域（100w行的那个背景颜色）不是这么大的话可以省略where
       End If
       fn = Dir
   Loop While Len(fn)
'-----------------------------------------------------------------------------------------
   sql = Join(fns, " Union All ") '连接各表格的sql语句生成
   Set conn = CreateObject("adodb.connection")
   Set rst = CreateObject("adodb.recordset")
   conn.Open "dsn=excel files;dbq=" & ThisWorkbook.FullName
   rst.Open sql, conn, 1, 1  '打开数据集方式（游标+只读）
   ReDim re(1 To rst.RecordCount, 1 To rst.Fields.Count) '定义结果数组大小
   cnt = 0
'-----------------------------------------------------------------------------------------
'循环去读所有记录到数组中
   Do Until rst.EOF = True
      cnt = cnt + 1
      For i = 0 To rst.Fields.Count - 1
         re(cnt, i + 1) = rst.Fields.Item(i)
      Next
      rst.movenext
   Loop
'-----------------------------------------------------------------------------------------
'关闭各对象
   rst.Close
   conn.Close
   Set rst = Nothing
   Set conn = Nothing
End Sub
'试试看行不行吧。。。

跳转到最佳答案楼层

ghostjiao

1. Sub demo()
   
2.     Dim cnn As Object, rst As Object, constr$, Sp$, Sn$, sql$, j%, n&
   
3.     Dim ar(1 To 1000000, 1 To 9), lrow, wb As Workbook
   
4.     Set cnn = CreateObject("adodb.connection")
   
5.     Set rst = CreateObject("adodb.recordset")
   
6.     Sp = ThisWorkbook.Path & ""
   
7.     Sn = Dir(Sp & "*.xl*")
   
8.     Do While Sn <> ""
   
9.         If Sn <> ThisWorkbook.Name Then
   
10.             Set wb = GetObject(Sp & Sn)
    
11.             lrow = wb.Sheets("销售明细").Cells(Rows.Count, "A").End(xlUp).Row
    
12.             wb.Close 0
    
13.             constr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Sp & Sn & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
    
14.             cnn.Open constr
    
15.             sql = "select * from[销售明细$A:I" & lrow & "]"
    
16.             rst.Open sql, cnn, 1, 3
    
17.             Do While Not rst.EOF
    
18.                 If rst.Fields(0).Value <> "编号" Then
    
19.                     n = n + 1
    
20.                     For j = 1 To 9
    
21.                         ar(n, j) = rst.Fields(j - 1).Value
    
22.                     Next
    
23.                 End If
    
24.                 rst.MoveNext
    
25.             Loop
    
26.             cnn.Close
    
27.         End If
    
28.         Sn = Dir
    
29.     Loop
    
30. End Sub
    

复制代码

打个酱油，顺版，嘿嘿
对于ADO和SQL也不怎么熟悉  看看勉强能用不

xdragon

Sub test()
   Dim fn$, pth$, cnt%, fns()
   Dim conn As Object, rst As Object, sql$, re$(), i&
   '变量说明：fn=文件名称，pth=文件路径，cnt=汇总文件的计数；结果数组的计数
   '变量说明：fns=存放局部sql语句，sql=最终执行的sql语句，re$()=最终结果数组（如果不需要全部为文本类型可取消定义文本）
   '变量说明：conn=ado连接数据库对象，rst=ado数据集对象，i=用于循环数据集中每列的存放记录
   pth = ThisWorkbook.Path & "\"
   fn = Dir(pth & "*.xls*")
'-----------------------------------------------------------------------------------------
   Do '循环读取工作表名并存放局部的sql语句到fns数组中
       If fn <> ThisWorkbook.Name Then
           cnt = cnt + 1
           ReDim Preserve fns(1 To cnt)
           fns(cnt) = "select * from [" & pth & fn & "].[销售明细$a2:i] where len(编号)"  '此处如果文件可用区域（100w行的那个背景颜色）不是这么大的话可以省略where
       End If
       fn = Dir
   Loop While Len(fn)
'-----------------------------------------------------------------------------------------
   sql = Join(fns, " Union All ") '连接各表格的sql语句生成
   Set conn = CreateObject("adodb.connection")
   Set rst = CreateObject("adodb.recordset")
   conn.Open "dsn=excel files;dbq=" & ThisWorkbook.FullName
   rst.Open sql, conn, 1, 1  '打开数据集方式（游标+只读）
   ReDim re(1 To rst.RecordCount, 1 To rst.Fields.Count) '定义结果数组大小
   cnt = 0
'-----------------------------------------------------------------------------------------
'循环去读所有记录到数组中
   Do Until rst.EOF = True
      cnt = cnt + 1
      For i = 0 To rst.Fields.Count - 1
         re(cnt, i + 1) = rst.Fields.Item(i)
      Next
      rst.movenext
   Loop
'-----------------------------------------------------------------------------------------
'关闭各对象
   rst.Close
   conn.Close
   Set rst = Nothing
   Set conn = Nothing
End Sub
'试试看行不行吧。。。