[已解决]vba 从一个工作簿根据条件把数据放入对应的工作簿

qh8600 · 发表于 2014-2-23 16:50

本帖最后由 qh8600 于 2014-2-24 13:08 编辑

公司.rar (28.03 KB, 下载次数: 11)

2014-2-23 16:49 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-2-24 12:52

本帖最后由 hwc2ycy 于 2014-2-24 12:57 编辑

Sub Main()
Dim clg As Collection
Set clg = New Collection
Call listFiles(ThisWorkbook.Path, clg)
If clg.Count = 0 Then
MsgBox "当前文件夹下无数据文件可写入", vbCritical + vbOKOnly
Exit Sub
End If
Call ADOWrite2(clg)
If MsgBox("清除汇总工作表中现有数据？", vbYesNo) = vbYes Then
'数据更新完成后，是否清除现有数据
ActiveSheet.UsedRange.Offset(2).ClearContents
End If
End Sub
Sub listFiles(strPath$, clg As Collection)
'---------------------------------------------------------------------------------------
' Procedure : listFiles
' Author : hwc2ycy
' Date : 2014/2/24
' Purpose : 生成文件列表，存入集合中
'---------------------------------------------------------------------------------------
Dim str$
Dim strFile As String
If Not Right(strPath, 1) = "" Then strPath = strPath & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
Do While Len(strFile)
If strFile <> ThisWorkbook.Name And strFile Like "*.xls" Then
str = Left(strFile, InStrRev(strFile, ".") - 1)
clg.Add str, str
End If
strFile = Dir
Loop
End Sub
Sub ADOWrite2(clg As Collection)
'---------------------------------------------------------------------------------------
' Procedure : ADOWrite2
' Author : hwc2ycy
' Date : 2014/2/24
' Purpose : 通过ADO组件执行SQL查询实现一表分类输出至多表
'---------------------------------------------------------------------------------------
Const adUseClient = 3
Const adModeReadWrite = 3
Const adModeRead = 1
Dim AdoConn As Object
Dim strConn$, strSQL$, strFullNameS$
Dim strFullName$, item
On Error GoTo ErrorHandler
Set AdoConn = CreateObject("ADODB.Connection")
strConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source='" & ThisWorkbook.FullName & "';Extended Properties='Excel 8.0;HDR=YES;imex=1';"
With AdoConn
.CursorLocation = adUseClient
.Mode = adModeRead
.ConnectionString = strConn
.Open
End With
For Each item In clg
strFullName = "[Excel 8.0;hdr=yes;imex=2;Database=" & ThisWorkbook.Path & Application.PathSeparator & item & ".xls]"
With AdoConn
strSQL = "insert into " & strFullName & ".[报表$] select 数据1,数据2,数据3,数据4,数据5,数据6 from [汇总$A2:G] where 单位='" & item & "'"
.Execute strSQL
strSQL = "insert into " & strFullName & ".[明细$] select 数据7,数据8,数据9 from [汇总$H2:K] where 单位='" & item & "'"
.Execute strSQL
End With
Next
AdoConn.Close
Application.ScreenUpdating = True
MsgBox "数据导出完成"
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & _
Err.Description
Application.ScreenUpdating = True
On Error Resume Next
AdoConn.Close
Set AdoConn = Nothing
End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy · 发表于 2014-2-23 17:32

应该是追加数据吧。

qh8600 · 发表于 2014-2-23 18:07

hwc2ycy 发表于 2014-2-23 17:32
应该是追加数据吧。

是啊，有好多工作簿，但是格式一样的

hwc2ycy · 发表于 2014-2-23 20:25

你刷新一次是不是把现在表内的数据全部复制到所有对应的工作簿的相关工作表？

qh8600 · 发表于 2014-2-23 20:43

hwc2ycy 发表于 2014-2-23 20:25
你刷新一次是不是把现在表内的数据全部复制到所有对应的工作簿的相关工作表？

是啊

qh8600 · 发表于 2014-2-23 20:44

hwc2ycy 发表于 2014-2-23 20:25
你刷新一次是不是把现在表内的数据全部复制到所有对应的工作簿的相关工作表？

不过要对应的，什么单位复制到什么单位

hwc2ycy · 发表于 2014-2-24 12:52

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

本帖最后由 hwc2ycy 于 2014-2-24 12:57 编辑

Sub Main()
Dim clg As Collection
Set clg = New Collection
Call listFiles(ThisWorkbook.Path, clg)
If clg.Count = 0 Then
MsgBox "当前文件夹下无数据文件可写入", vbCritical + vbOKOnly
Exit Sub
End If
Call ADOWrite2(clg)
If MsgBox("清除汇总工作表中现有数据？", vbYesNo) = vbYes Then
'数据更新完成后，是否清除现有数据
ActiveSheet.UsedRange.Offset(2).ClearContents
End If
End Sub
Sub listFiles(strPath$, clg As Collection)
'---------------------------------------------------------------------------------------
' Procedure : listFiles
' Author : hwc2ycy
' Date : 2014/2/24
' Purpose : 生成文件列表，存入集合中
'---------------------------------------------------------------------------------------
Dim str$
Dim strFile As String
If Not Right(strPath, 1) = "" Then strPath = strPath & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
Do While Len(strFile)
If strFile <> ThisWorkbook.Name And strFile Like "*.xls" Then
str = Left(strFile, InStrRev(strFile, ".") - 1)
clg.Add str, str
End If
strFile = Dir
Loop
End Sub
Sub ADOWrite2(clg As Collection)
'---------------------------------------------------------------------------------------
' Procedure : ADOWrite2
' Author : hwc2ycy
' Date : 2014/2/24
' Purpose : 通过ADO组件执行SQL查询实现一表分类输出至多表
'---------------------------------------------------------------------------------------
Const adUseClient = 3
Const adModeReadWrite = 3
Const adModeRead = 1
Dim AdoConn As Object
Dim strConn$, strSQL$, strFullNameS$
Dim strFullName$, item
On Error GoTo ErrorHandler
Set AdoConn = CreateObject("ADODB.Connection")
strConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source='" & ThisWorkbook.FullName & "';Extended Properties='Excel 8.0;HDR=YES;imex=1';"
With AdoConn
.CursorLocation = adUseClient
.Mode = adModeRead
.ConnectionString = strConn
.Open
End With
For Each item In clg
strFullName = "[Excel 8.0;hdr=yes;imex=2;Database=" & ThisWorkbook.Path & Application.PathSeparator & item & ".xls]"
With AdoConn
strSQL = "insert into " & strFullName & ".[报表$] select 数据1,数据2,数据3,数据4,数据5,数据6 from [汇总$A2:G] where 单位='" & item & "'"
.Execute strSQL
strSQL = "insert into " & strFullName & ".[明细$] select 数据7,数据8,数据9 from [汇总$H2:K] where 单位='" & item & "'"
.Execute strSQL
End With
Next
AdoConn.Close
Application.ScreenUpdating = True
MsgBox "数据导出完成"
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & _
Err.Description
Application.ScreenUpdating = True
On Error Resume Next
AdoConn.Close
Set AdoConn = Nothing
End Sub

复制代码

hwc2ycy · 发表于 2014-2-24 13:01

汇总.rar (19.6 KB, 下载次数: 16)

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