VBA汇总统一文件夹下的多个表格的数据？

大家好，今天继续讲解《VBA数据库解决方案》，今日讲解的是第37讲，利用ADO，实现同一文件夹下多个EXCEL工作表的数据汇总。最近的内容实用性比较强，如今日的内容，只把需要汇总的EXCEL文件放在同一个文件夹下，而且格式一致，那么利用ADO汇总这几个文件的数据是非常快的,这讲的内容和第32讲的内容是类似的，不过第32讲的内容是要事先知道文件的名称，然后建立一个数组来分别对应每个文件，通过循环来实现从每个文件中提取数据的目的，本讲的内容是事先不知道每个文件的名称。

实例：在一个文件夹下有若干个文件，如下图：

我们现在，需要把上面的文件夹中除了“VBA与数据库 *** 作”之外的各个文件的内容一次性汇总出来，这个VBA程序该如何写呢？代码如下：

Sub mynzexcels_6()

'第37讲，利用ADO,实现同一文件夹下EXCEL工作表数据的汇总

Dim cnADO As Object

Dim strPath, strTable, strSQL, Z As String

Set cnADO = CreateObject("ADODB.Connection")

Range("a:g").ClearContents

Range("a1:e1") = Array("日期", "型号", "批号", "出库数量", "库存数量")

Z = Dir(ThisWorkbook.Path &"\*.*")

strPath = ThisWorkbook.Path &"\" &Z

strTable = "[sheet1$A2:h65536]"

'建立连接,提取数据

x = 2

Do While Z <>""

If Z <>"VBA与数据库 *** 作.xlsm" Then

cnADO.Open "provider=Microsoft.ACE.OLEDB.12.0extended properties='excel 8.0hdr=noimex=1'data source=" &strPath

strSQL = "select F1,F2,F3,F4,F5 from " &strTable

Range("A" &x).CopyFromRecordset cnADO.Execute(strSQL)

x = Range("b65536").End(xlUp).Row

cnADO.Close

End If

Z = Dir

Loop

Set cnADO = Nothing

End Sub

代码截图：

代码讲解：

1 Z = Dir(ThisWorkbook.Path &"\*.*") 其中DIR函数用来指定文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。如果没有找到 pathname，则会返回零长度字符串 ("")。

2 strPath = ThisWorkbook.Path &"\" &Z

strTable = "[sheet1$A2:h65536]"

上述代码分别给出了文件的路径名称和数据表的范围，数据的范围是sheet1工作表除去表头后的全部$A2:h65536.

3 strSQL = "select F1,F2,F3,F4,F5 from " &strTable

Range("A" &x).CopyFromRecordset cnADO.Execute(strSQL)

建立连接后把需要的数据拷贝出来，需要的数据是第1列，第2列，第3列，第4列 ，第5列

4 x = Range("b65536").End(xlUp).Row 下次复制的位置确定.

5 Z = Dir

特别注意：第一次调用 Dir 函数时，必须指定 pathname，否则会产生错误。如果也指定了文件属性，那么就必须包括 pathname。Dir 会返回匹配 pathname 的第一个文件名。若想得到其它匹配 pathname 的文件名，再一次调用 Dir，且不要使用参数。如果已没有合乎条件的文件，则 Dir 会返回一个零长度字符串 ("")。一旦返回值为零长度字符串，并要再次调用 Dir 时，就必须指定 pathname，否则会产生错误。不必访问到所有匹配当前 pathname 的文件名，就可以改变到一个新的 pathname 上。但是，不能以递归方式来调用 Dir 函数。以 vbDirectory 属性来调用 Dir 不能连续地返回子目录。由于文件名并不会以特别的次序来返回，所以可以将文件名存储在一个数组中，然后再对这个数组排序。

上述的Z=dir 就是实现的下一个文件名的调用。

下面看运行的结果：

点击“ADO实现同文件夹下所有文件数据汇总”按钮：

汇总后再A到E列给出了数据的汇总：

今日内容回向：

1 在不知道文件名和文件个数的前提下，如何汇总文件？

2 DIR函数的意义是否理解？

读取和写入 *** 作方式一样，唯一不同的是sql语句，读取用select，读取用insert，以读取为例子，录入如下代码：

'sql完整例子

Sub testSql()

'定义连接对象

    Dim cnn As New ADODB.Connection

    Dim rs As New ADODB.Recordset

   

    '定义连接字符串

    Dim conStr As String

    Dim sqlstr As String

    '连接字符串-以下是连接MSSQL数据库

    conStr = "Provider=sqloledb" _

    &"Server=192.168.1.121" _

    &"Database=DATABASENAMEUid=adminPwd=admin"

    cnn.Open conStr

   

    sqlstr = "SELECT * from tablename"

    rs.Open sqlstr, cnn

    Range("a2").CopyFromRecordset rs

    rs.Close

    cnn.Close

End Sub

VBA

连接

SQL

SERVER

数据库

实例:

Dim

strConn

As

String,

strSQL

As

String

Dim

conn

As

ADODB.Connection

Dim

ds

As

ADODB.Recordset

Dim

col

As

Integer

'连接数据库的字符串

strConn

=

"Provider=SQLOLEDB.1Persist

Security

Info=TrueUser

ID=[user]Password=[password]Initial

Catalog=[database]Data

Source=[数据库IP地址或数据库服务器名称]Connect

Timeout=720

"

'查询语句，如果sql语句很长可以用strSQL=strSQL+来连接分成多段的语句，如果语句很短可以只写在一行上。

strSQL

=

"select

*

from

Hy_KPI_Shop_Dept_WeekRpt

"

strSQL

=

strSQL+"where

sdate='2014-01-01'

order

by

sdate,shopid

"

Set

conn

=

New

ADODB.Connection

Set

ds

=

New

ADODB.Recordset

'打开数据库连接

conn.Open

strConn

'该句和数据库连接字符串处的Connect

Timeout=720，表示说如果语句运行时间很长，这两句可以延长vba的等待时间，没有这两句，vba往往会报查询超时。

conn.CommandTimeout

=

720

With

ds

'根据查询语句获得数据

.Open

strSQL,

conn

'自动控制加入所有列标题

For

col

=

0

To

ds.Fields.Count

-

1

'请注意Offset(0,

col)中的参数一定要正确，该句表示标题将会写在第一行，从A1单元格开始，如果不想写入标题行，可将下面这句注释掉。

Worksheets("门店各课KPI周报").Range("A1").Offset(0,

col).Value

=

ds.Fields(col).Name

Next

'加入所有行数据，该句表示查询结果将会写在第一行，从A1单元格开始，但是由于标题行写在第一行了，所以实际这一行从标题下的一行写入。

Worksheets("sheet1").Range("A1").Offset(1,

0).CopyFromRecordset

ds

End

With

'关闭数据库连接和清空资源

Set

ds

=

Nothing

conn.Close

Set

conn

=

Nothing

---