[已解决]请vba老师帮忙合并代码，取消中间步骤

武林长风

我之前这样做的：用vba将各校成绩单文件夹里的成绩整理新成绩单；再把新成绩单工作簿的1-6年级工作表的A-I列复制到考试成统计工作簿的对应年级里，不删除这里的1-6年级工作表，否则汇总表里的公式会出现错误。
       现在我想可否去掉中间的整理成绩单这步，直接从各校成绩单文件夹里把每个学校的1-6年级像新成绩单那样的表导入到考试成统计工作簿的1-6 年级工作表里。谢谢您！！！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-7-15 11:20

请看附件。导入的数据只含纯数据，原先中间的那些表头全没了。不影响统计。

跳转到最佳答案楼层

grf1973

1. Sub 复制成绩()
   
2.     Application.Calculation = xlCalculationManual
   
3.     Application.ScreenUpdating = False
   
4.     Dim Filename, wb As Workbook, Sh As Worksheet
   
5.     Filename = Dir(ThisWorkbook.Path & "\各校成绩单\*.xls")
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.    
   
8.     For Each Sh In ThisWorkbook.Worksheets     '清空原各年级表中数据
   
9.         If Sh.Name Like "*年级" Then Sh.[a2:i10000].ClearContents
   
10.     Next
    
11.    
    
12.     Do While Filename <> ""
    
13.             fn = ThisWorkbook.Path & "\各校成绩单" & Filename
    
14.             Set wb = Workbooks.Open(fn)
    
15.             With wb.Worksheets(1)
    
16.                 arr = .[a1].CurrentRegion
    
17.                 For i = 3 To UBound(arr)
    
18.                     nj = arr(i, 2)         '年级所在列
    
19.                     If nj Like "*年*" Then
    
20.                         nj = Mid(nj, InStr(nj, "年") - 1, 1) & "年级"       '年级
    
21.                         If Not d.exists(nj) Then
    
22.                             Set d(nj) = .Cells(i, 1).Resize(1, 9)
    
23.                         Else
    
24.                             Set d(nj) = Union(d(nj), .Cells(i, 1).Resize(1, 9))
    
25.                         End If
    
26.                     End If
    
27.                 Next
    
28.             End With
    
29.             For Each Sh In ThisWorkbook.Worksheets
    
30.                 If Sh.Name Like "*年级" Then
    
31.                     If d.exists(Sh.Name) Then
    
32.                         r = Sh.[a65536].End(3).Row + 1
    
33.                         d(Sh.Name).Copy Sh.Cells(r, 1)
    
34.                     End If
    
35.                 End If
    
36.             Next
    
37.             wb.Close False
    
38.             d.RemoveAll
    
39.         Filename = Dir
    
40.     Loop
    
41.     Set Sh = Nothing
    
42.     Application.Calculation = xlCalculationAutomatic
    
43.     Application.ScreenUpdating = True
    
44. End Sub
    

复制代码

grf1973

请看附件。导入的数据只含纯数据，原先中间的那些表头全没了。不影响统计。

武林长风

grf1973 发表于 2015-7-15 11:20
请看附件。导入的数据只含纯数据，原先中间的那些表头全没了。不影响统计。

成绩单复制时，可否把标题这些加在第一行

序号

学校

姓 名

考号

数学

语文

武林长风

grf1973 发表于 2015-7-15 11:20
请看附件。导入的数据只含纯数据，原先中间的那些表头全没了。不影响统计。

不麻烦了，我在目标表加上就行了。谢谢！！！