如何通过VBA实现跨工作簿、工作表间的复制黏贴？

尐_Oo_超.超

1. 这里有2个工作簿，希望通过VBA，将“评分表”的2张工作表数据填到“结果表”的对应工作表中。（“结果表”的每张工作表格式相同）
2. 工作簿名称更改后，如按月份更改，希望代码可以照常运行。
PS:由于才刚学VBA，很多知识点没法运用到实际工作中，希望各位大神能够帮帮忙，谢谢！
跨工作簿.rar (15.4 KB, 下载次数: 298)

2014-6-22 23:01 上传

点击文件名下载附件

zhaogang1960

ADO+数组+字典法，请参考：

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object, i&, s$, t$, SQL$, d As Object, sh As Worksheet
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set cnn = CreateObject("ADODB.Connection")
   
5.     cnn.Open "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source =" & ThisWorkbook.Path & "" & Split(ThisWorkbook.Name, "月")(0) & "月评分表.xlsx"
   
6.     Set rs = cnn.OpenSchema(20) 'adSchemaTables
   
7.     Do Until rs.EOF
   
8.         If rs.Fields("TABLE_TYPE") = "TABLE" Then
   
9.             s = Replace(rs("TABLE_NAME").Value, "'", "")
   
10.             If Right(s, 1) = "$" Then
    
11.                 arr = cnn.Execute("[" & s & "]").GetRows
    
12.                 For i = 0 To UBound(arr, 2)
    
13.                     If Not IsNull(arr(0, i)) Then t = arr(0, i)
    
14.                     d(t & vbTab & arr(1, i)) = arr(2, i)
    
15.                 Next
    
16.             End If
    
17.         End If
    
18.         rs.MoveNext
    
19.     Loop
    
20.     For Each sh In Sheets
    
21.         s = sh.Name
    
22.         arr = sh.[a1].CurrentRegion
    
23.         ReDim brr(2 To UBound(arr), 1 To 1)
    
24.         For i = 2 To UBound(arr)
    
25.             brr(i, 1) = d(s & vbTab & arr(i, 1))
    
26.         Next
    
27.         sh.[b2].Resize(i - 2) = brr
    
28.     Next
    
29.     rs.Close
    
30.     Set rs = Nothing
    
31.     cnn.Close
    
32.     Set cnn = Nothing
    
33. End Sub
    

复制代码

zhaogang1960

说明：数据源命名方法是——某月评分表，其中某月同程序所在工作簿的月份
请测试附件
跨工作簿.rar (26.55 KB, 下载次数: 800)

2014-6-22 23:27 上传

点击文件名下载附件

尐_Oo_超.超

zhaogang1960 发表于 2014-6-22 23:27
说明：数据源命名方法是——某月评分表，其中某月同程序所在工作簿的月份
请测试附件

十分感谢赵老师的帮助！
我努力尝试对每行代码学习了一下，但是知识体系十分凌乱，不明白具体的含义。
假设评分表1的数据是F4：F103和J4：J103，需分别填入结果表对应工作表的F3：F10，姓名为25个，这样该怎么编写代码呢？谢谢赵老师！

zhaogang1960

尐_Oo_超.超 发表于 2014-6-24 12:15
十分感谢赵老师的帮助！
我努力尝试对每行代码学习了一下，但是知识体系十分凌乱，不明白具体的含义。
...

不知所云，请模拟效果

尐_Oo_超.超

zhaogang1960 发表于 2014-6-24 15:55
不知所云，请模拟效果

如果把两个工作簿的表格拓展一下，代码该如何编写呢？
请查看附件：
6月考核.rar (38.11 KB, 下载次数: 62)

2014-6-30 12:11 上传

点击文件名下载附件

zhaogang1960

尐_Oo_超.超 发表于 2014-6-30 12:12
如果把两个工作簿的表格拓展一下，代码该如何编写呢？
请查看附件：

1. Sub Macro1()
   
2.     Dim cnn As Object, i&, s$, t$, SQL$, d As Object, sh As Worksheet
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set cnn = CreateObject("ADODB.Connection")
   
5.     cnn.Open "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties ='Excel 12.0;hdr=no';Data Source =" & ThisWorkbook.Path & "" & Split(ThisWorkbook.Name, "月")(0) & "月评分表.xlsx"
   
6.     arr = cnn.Execute("select * from [评分表$a4:j] where f2 is not null").GetRows
   
7.     For i = 0 To UBound(arr, 2)
   
8.         If Not IsNull(arr(0, i)) Then t = arr(0, i)
   
9.         d(t & vbTab & arr(1, i) & vbTab & "一") = arr(5, i)
   
10.         d(t & vbTab & arr(1, i) & vbTab & "二") = arr(9, i)
    
11.     Next
    
12.     For Each sh In Sheets
    
13.         s = sh.Name
    
14.         arr = sh.[a1].CurrentRegion
    
15.         ReDim brr(3 To UBound(arr), 1 To 1)
    
16.         For i = 3 To UBound(arr)
    
17.             If Len(arr(i, 1)) Then t = arr(i, 1)
    
18.             brr(i, 1) = d(s & vbTab & arr(i, 2) & vbTab & t)
    
19.         Next
    
20.         sh.[f3].Resize(i - 3) = brr
    
21.     Next
    
22.     Set rs = Nothing
    
23.     Set cnn = Nothing
    
24. End Sub
    

复制代码

zhaogang1960

请测试附件

6月考核.rar (53.89 KB, 下载次数: 660)

2014-6-30 16:19 上传

点击文件名下载附件

尐_Oo_超.超

zhaogang1960 发表于 2014-6-30 16:20
请测试附件

赵老师太厉害了，向您学习！

angel_morning

zhaogang1960 发表于 2014-6-30 16:18

赵老师您好，想请教您一个问题，如何跨工作簿，将其他工作簿的工作表复制到当前活动的工作簿的最后。