取多个工作薄中指定内容至同一个工作薄相应子表中

ljming · 发表于 2015-7-21 16:52

我想取附件中各个月工作薄中地市为“汕头”的内容至汇总工作薄相应的子表中，怎么处理呢，请指教，我尝试了：
Sub 各月报类汇总()
Set conn = CreateObject("ADODB.Connection")
conn.Open "provider=Microsoft.Ace.OleDb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.Path & "\7月.xlsx"
Sql = "select * from [sheet1$] where 地市='汕头'"
Sheets(1).[a2].CopyFromRecordset conn.Execute(Sql)
conn.Close: Set conn = Nothing
End Sub

但运行出错，也不知原因出错，麻烦指导下。

附件.rar (248.21 KB, 下载次数: 14)

ljming · 发表于 2015-7-21 21:42

{:soso_e154:}麻烦高人再帮忙看看

zhaogang1960 · 发表于 2015-7-22 10:05

请参考:

Sub 各月报类汇总()
Dim cnn As Object, rs As Object, rst As Object, SQL$, s$, p$, f$, sh As Worksheet
p = ThisWorkbook.Path & ""
f = Dir(p & "*.xlsx")
Do While f <> ""
On Error Resume Next
Set sh = Worksheets(Replace(f, ".xlsx", ""))
On Error GoTo 0
If Not sh Is Nothing Then
sh.UsedRange.ClearContents
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & p & f
Set rs = cnn.OpenSchema(20)
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
s = Replace(rs("TABLE_NAME").Value, "'", "")
If Right(s, 1) = "$" Then
SQL = "select * from [" & s & "] where 地市='汕头'"
Set rst = cnn.Execute(SQL)
For i = 1 To rst.Fields.Count
sh.Cells(1, i) = rst.Fields(i - 1).Name
Next
sh.[a2].CopyFromRecordset rst
End If
End If
rs.MoveNext
Loop
End If
f = Dir()
Loop
rs.Close
rst.Close
cnn.Close
Set rs = Nothing
Set rst = Nothing
Set cnn = Nothing
End Sub

复制代码

zhaogang1960 · 发表于 2015-7-22 10:06

请测试附件

附件.rar (256.3 KB, 下载次数: 30)

wangg913 · 发表于 2015-7-22 10:09

Sql = "select * from [7月<440>$] where 地市='汕头'"

复制代码

ljming · 发表于 2015-7-22 13:14

zhaogang1960 发表于 2015-7-22 10:05
请参考:

谢谢指导，但还有点小问题，1、就是如果工作薄都不是.XLSX结尾就失效了，有个别是.XLS的；2、如果工作薄有多个子表也会出错;

我重新上传了附件，麻烦帮忙{:soso_e163:}

附件2.rar (270.14 KB, 下载次数: 4)

zhaogang1960 · 发表于 2015-7-22 14:12

ljming 发表于 2015-7-22 13:14
谢谢指导，但还有点小问题，1、就是如果工作薄都不是.XLSX结尾就失效了，有个别是.XLS的；2、如果工作薄 ...

Sub 各月报类汇总()
Dim cnn As Object, rs As Object, rst As Object, SQL$, s$, wn$, p$, f$, m&, sh As Worksheet
p = ThisWorkbook.Path & ""
f = Dir(p & "*.xls*")
Do While f <> ""
If Right(f, 5) = ".xlsx" Or Right(f, 4) = ".xls" Then
wn = Split(f, ".")(0)
On Error Resume Next
Set sh = Worksheets(wn)
On Error GoTo 0
If Not sh Is Nothing Then
sh.UsedRange.ClearContents
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & p & f
Set rs = cnn.OpenSchema(20)
m = 0
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
s = Replace(rs("TABLE_NAME").Value, "'", "")
If Right(s, 1) = "$" Then
m = m + 1
SQL = "select * from [" & s & "] where 地市='汕头'"
Set rst = cnn.Execute(SQL)
If m = 1 Then
For i = 1 To rst.Fields.Count
sh.Cells(1, i) = rst.Fields(i - 1).Name
Next
End If
sh.Range("A" & sh.Rows.Count).End(xlUp).Offset(1).CopyFromRecordset rst
End If
End If
rs.MoveNext
Loop
End If
End If
f = Dir()
Loop
rs.Close
rst.Close
cnn.Close
Set rs = Nothing
Set rst = Nothing
Set cnn = Nothing
End Sub

复制代码

zhaogang1960 · 发表于 2015-7-22 14:13

请测试附件

附件2.rar (266.41 KB, 下载次数: 31)

ljming · 发表于 2015-7-22 15:48

zhaogang1960 发表于 2015-7-22 14:13
请测试附件

再次感谢~谢谢你的指导。

LMY123 · 发表于 2018-8-17 09:03

本帖最后由 LMY123 于 2018-8-24 10:58 编辑

合并工作薄所有工作表，写入总薄对应的工作表中
Set rs = cnn.OpenSchema(20)

补充内容 (2019-1-2 17:16):
已入库

		自动登录	找回密码
密码			免费注册

[求助] 取多个工作薄中指定内容至同一个工作薄相应子表中

评分

评分