求助导入不同工作簿中数据问题

lalitou

需要把test1 表1 a2:a6中的数据放到 test2 表1  b2:b6中test1 表2 a2:a6 中的数据放 到 test2 表2 b2:b6 中
test1 表3 a2:a6 中的数据放到 test2 表3  b2:b6 中
test.zip (2.9 KB, 下载次数: 5)

2014-1-30 14:49 上传

点击文件名下载附件

这只是为了说明用的表格，实际中没个工作簿有上百张表，每张表有几十列。靠复制粘贴工作量太大，特来求助。{:soso_e100:}

zhaogang1960

如果数据符合数据库标准，即第一行是标题，可以考虑ADO法：

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object, SQL$, i&, sh As Worksheet
   
3.     Set cnn = CreateObject("ADODB.Connection")
   
4.     cnn.Open "Provider = Microsoft.ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source =" & ThisWorkbook.Path & "\test1.xls"
   
5.     For Each sh In Sheets
   
6.         SQL = "Select * from [" & sh.Name & "$]"
   
7.         Set rs = cnn.Execute(SQL)
   
8.         sh.Cells.ClearContents
   
9.         For i = 1 To rs.Fields.Count
   
10.             sh.Cells(1, i) = rs.Fields(i - 1).Name
    
11.         Next
    
12.         sh.[a2].CopyFromRecordset rs
    
13.     Next
    
14.     rs.Close
    
15.     cnn.Close
    
16.     Set rs = Nothing
    
17.     Set cnn = Nothing
    
18. End Sub
    

复制代码

zhaogang1960

ADO法没有Open打开工作簿过程，速度较快
请测试附件
test.rar (9.15 KB, 下载次数: 11)

2014-1-30 15:28 上传

点击文件名下载附件

CheryBTL

学习版主的思路，我来个绿叶衬托一下：

1. Sub test()
   
2.     Dim i As Integer
   
3.     Dim str As String, ar
   
4.     str = ThisWorkbook.Path & "/test2.xls"
   
5.     Workbooks.Open str
   
6.     With Workbooks(2)
   
7.         For i = 1 To Sheets.Count
   
8.             ar = Workbooks(1).Sheets(i).Range("A1").CurrentRegion
   
9.             .Sheets(i).[a1].Resize(UBound(ar), UBound(ar, 2)) = ar
   
10.         Next
    
11.         .Close savechanges:=True
    
12.     End With
    
13. End Sub
    

复制代码

zhaogang1960

CheryBTL 发表于 2014-1-30 15:12
学习版主的思路，我来个绿叶衬托一下：

你这个的思路与我正相反，我代码是在test2工作簿中
让楼主自己选择吧

CheryBTL

zhaogang1960 发表于 2014-1-30 15:14
你这个的思路与我正相反，我代码是在test2工作簿中
让楼主自己选择吧

只有二个工作薄的话，可能影响不大

我本想用工作表的COPY方法，学艺不精，只好用数组了。

lalitou

zhaogang1960 发表于 2014-1-30 15:14
你这个的思路与我正相反，我代码是在test2工作簿中
让楼主自己选择吧

运行你的程序会出错，什么问题，能帮我下吗？

lalitou

CheryBTL 发表于 2014-1-30 15:20
只有二个工作薄的话，可能影响不大

我本想用工作表的COPY方法，学艺不精，只好用数组了。

已经很好了，我什么方法都想不道，脑子一团浆糊。

zhaogang1960

lalitou 发表于 2014-1-30 15:22
运行你的程序会出错，什么问题，能帮我下吗？

我犯糊涂了，给你写了个2010版本的，下面是2003版

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object, SQL$, i&, sh As Worksheet
   
3.     Set cnn = CreateObject("ADODB.Connection")
   
4.     cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties =Excel 8.0;Data Source =" & ThisWorkbook.Path & "\test1.xls"
   
5.     For Each sh In Sheets
   
6.         SQL = "Select * from [" & sh.Name & "$]"
   
7.         Set rs = cnn.Execute(SQL)
   
8.         sh.Cells.ClearContents
   
9.         For i = 1 To rs.Fields.Count
   
10.             sh.Cells(1, i) = rs.Fields(i - 1).Name
    
11.         Next
    
12.         sh.[a2].CopyFromRecordset rs
    
13.     Next
    
14.     rs.Close
    
15.     cnn.Close
    
16.     Set rs = Nothing
    
17.     Set cnn = Nothing
    
18. End Sub
    

复制代码

lalitou

zhaogang1960 发表于 2014-1-30 15:27
我犯糊涂了，给你写了个2010版本的，下面是2003版

谢谢，我试试。