[已解决]请教大神：VBA怎样跨工作簿复制数据？

白云无尽9987

请教大神：VBA怎样跨工作簿复制数据？.rar (363.07 KB, 下载次数: 24)

2015-11-30 09:39 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-11-30 10:39

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Do While Filename <> ""
   
7.         If Filename <> ThisWorkbook.Name Then
   
8.             fn = ThisWorkbook.Path & "" & Filename
   
9.             Set wb = Workbooks.Open(fn)
   
10.             Set Sht = wb.Worksheets("班级分册")
    
11.             r = Sht.[r65536].End(3).Row      '数据最大行
    
12.             c = [a1].CurrentRegion.Columns.Count     '成绩最大列
    
13.             arr = Sht.Range("a1:r" & r)
    
14.             For i = 3 To UBound(arr)
    
15.                 xh = arr(i, 18)   'r列学号
    
16.                 If Not IsError(xh) Then
    
17.                 If Len(xh) > 0 Then
    
18.                     For j = 2 To c
    
19.                         d(xh & arr(2, j)) = arr(i, j)    'd(学号&科目)=成绩
    
20.                     Next
    
21.                 End If
    
22.                 End If
    
23.             Next
    
24.             wb.Close False
    
25.         End If
    
26.         Filename = Dir
    
27.     Loop
    
28.     With ActiveSheet
    
29.         r = .[a65536].End(3).Row
    
30.         arr = .Range("a1:p" & r)
    
31.         For i = 6 To UBound(arr)
    
32.             xh = arr(i, 1)    '学号
    
33.             For j = 2 To UBound(arr, 2)
    
34.                 arr(i, j) = d(xh & arr(5, j))        '成绩=d(学号&科目)
    
35.             Next
    
36.         Next
    
37.         .Range("a1:p" & r) = arr
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40. End Sub

复制代码

跳转到最佳答案楼层

Tank008

这个课程是你需要的：
http://edu.51cto.com/course/course_id-3580.html

grf1973

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Do While Filename <> ""
   
7.         If Filename <> ThisWorkbook.Name Then
   
8.             fn = ThisWorkbook.Path & "" & Filename
   
9.             Set wb = Workbooks.Open(fn)
   
10.             Set Sht = wb.Worksheets("班级分册")
    
11.             r = Sht.[r65536].End(3).Row      '数据最大行
    
12.             c = [a1].CurrentRegion.Columns.Count     '成绩最大列
    
13.             arr = Sht.Range("a1:r" & r)
    
14.             For i = 3 To UBound(arr)
    
15.                 xh = arr(i, 18)   'r列学号
    
16.                 If Not IsError(xh) Then
    
17.                 If Len(xh) > 0 Then
    
18.                     For j = 2 To c
    
19.                         d(xh & arr(2, j)) = arr(i, j)    'd(学号&科目)=成绩
    
20.                     Next
    
21.                 End If
    
22.                 End If
    
23.             Next
    
24.             wb.Close False
    
25.         End If
    
26.         Filename = Dir
    
27.     Loop
    
28.     With ActiveSheet
    
29.         r = .[a65536].End(3).Row
    
30.         arr = .Range("a1:p" & r)
    
31.         For i = 6 To UBound(arr)
    
32.             xh = arr(i, 1)    '学号
    
33.             For j = 2 To UBound(arr, 2)
    
34.                 arr(i, j) = d(xh & arr(5, j))        '成绩=d(学号&科目)
    
35.             Next
    
36.         Next
    
37.         .Range("a1:p" & r) = arr
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40. End Sub

复制代码

白云无尽9987

grf1973 发表于 2015-11-30 10:39

感激不尽，大神！！

grf1973

插入2列

白云无尽9987

grf1973 发表于 2015-12-2 20:38
插入2列

就是汇总插入列，多谢老师耐心帮教！！......哎，像我这种水平的学生是不是非常淘神？！