[已解决]上传成绩表（太具有挑战性的VBA程序编辑）

long826121

首先非常感谢各位！
“上传”文件中点击“上传成绩”按钮要实现的功能：
把“单元成绩”文件夹中语文数学的成绩上传到“学生成绩表”中。
1、当“考试名称”中有本次考试成绩时，提醒“本次考试成绩已上传,是否覆盖？”。如果是，就覆盖原来的。如果否，退出。
2、当“考试名称”中没有本次考试成绩时，提醒“本次考试上传成功”。
【“考试名称”顺序依次是：第一单元测试、第二单元测试、第一阶段月考、第三单元测试、第四单元测试、第二阶段月考、期中测试、第五单元测试、第六单元测试、第三阶段月考、第七单元测试、第八单元测试、第四阶段月考、第一次期末测试、第二次期末测试、期末测试】（注意考虑下：上传文件的顺序不同，但“考试名称”顺序不变。存在插入表格）
上传成绩.rar (85.58 KB, 下载次数: 13)

2014-5-10 17:11 上传

点击文件名下载附件 ("考试名称"就是“语文、数学”文件夹中excel文件的文件名)

最佳答案

月排行榜 / 总排行榜

dsmch

2014-5-10 17:12

重新整合了代码：自动对应学科、考试名称

跳转到最佳答案楼层

dsmch

重新整合了代码：自动对应学科、考试名称

dsmch

1. Dim arr(), s&
   
2. Sub 提取()
   
3. Dim wb As Workbook, brr, crr(1 To 60000, 1 To 4), d
   
4. Set d = CreateObject("scripting.dictionary")
   
5. s = 0
   
6. ReDim arr(1 To 1000, 1 To 1)
   
7. Zdir ThisWorkbook.Path & "\单元成绩"
   
8. Application.ScreenUpdating = False
   
9. Range("a2:d65536").ClearContents
   
10. For i = 1 To s
    
11.     Set wb = GetObject(arr(i, 1))
    
12.     zf = Replace(wb.Name, ".xls", "")
    
13.     brr = wb.Sheets(1).Range("a1").CurrentRegion
    
14.     For j = 2 To UBound(brr)
    
15.         z = zf & "," & brr(j, 1)
    
16.         If Not d.Exists(z) Then
    
17.             n = n + 1
    
18.             d(z) = n
    
19.             crr(n, 1) = zf
    
20.             crr(n, 2) = brr(j, 1)
    
21.             crr(n, 3) = brr(j, 2)
    
22.         Else
    
23.             crr(d(z), 4) = brr(j, 2)
    
24.         End If
    
25.     Next
    
26.     wb.Close 0
    
27. Next
    
28. Range("a2").Resize(n, 4) = crr
    
29. Application.ScreenUpdating = True
    
30. End Sub
    
31. Sub Zdir(P)
    
32. Set fs = CreateObject("scripting.filesystemobject")
    
33. For Each f In fs.GetFolder(P).Files
    
34.     s = s + 1
    
35.     arr(s, 1) = f
    
36. Next
    
37. For Each m In fs.GetFolder(P).SubFolders
    
38.     Zdir m
    
39. Next
    
40. End Sub
    

复制代码

dsmch

………………

long826121

dsmch 发表于 2014-5-10 21:07
………………

得到的结果乱了，
我想要的结果：【“考试名称”顺序依次是：第一单元测试、第二单元测试、第一阶段月考、第三单元测试、第四单元测试、第二阶段月考、期中测试、第五单元测试、第六单元测试、第三阶段月考、第七单元测试、第八单元测试、第四阶段月考、第一次期末测试、第二次期末测试、期末测试】
可以再修改下吗？非常感谢！
其实直接按“考试名称”顺序依次把姓名和分数依次复制过去就是。
上传成绩.rar (90.13 KB, 下载次数: 11)

2014-5-10 21:55 上传

点击文件名下载附件

long826121

dsmch 发表于 2014-5-10 21:07
………………

4楼有附件！“上传”文件中红色区域你就可以看见。

dsmch

提取后执行排序

1. Sub 排序()
   
2. Dim arr, brr, i%, j&, k%, s&
   
3. w = Array("第一单元测试", "第二单元测试", "第一阶段月考", "第三单元测试", "第四单元测试", "第二阶段月考", "期中测试", "第五单元测试", "第六单元测试", "第三阶段月考", "第七单元测试", "第八单元测试", "第四阶段月考", "第一次期末测试", "第二次期末测试", "期末测试")
   
4. arr = Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr, 2))
   
6. For i = 0 To UBound(w)
   
7.     For j = 2 To UBound(arr)
   
8.         If w(i) = arr(j, 1) Then
   
9.             s = s + 1
   
10.             For k = 1 To UBound(arr, 2)
    
11.                 brr(s, k) = arr(j, k)
    
12.             Next
    
13.         End If
    
14.     Next
    
15. Next
    
16. Range("a2").Resize(UBound(brr), 4) = brr
    
17. End Sub
    

复制代码

dsmch

1. Dim arr(), s&
   
2. Sub 提取()
   
3. Dim wb As Workbook, brr, crr, d, d2
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. w = Array("第一单元测试", "第二单元测试", "第一阶段月考", "第三单元测试", "第四单元测试", "第二阶段月考", "期中测试", "第五单元测试", "第六单元测试", "第三阶段月考", "第七单元测试", "第八单元测试", "第四阶段月考", "第一次期末测试", "第二次期末测试", "期末测试")
   
7. s = 0: [e1] = "顺序": n = 1
   
8. ReDim arr(1 To 1000, 1 To 1)
   
9. Zdir ThisWorkbook.Path & "\单元成绩" '递归搜索文件
   
10. Application.ScreenUpdating = False
    
11. Range("a2:d65536").ClearContents
    
12. crr = [a1:e60000]
    
13. For i = 0 To UBound(w) '自定义排序
    
14.     d2(w(i)) = i
    
15. Next
    
16. For i = 3 To UBound(crr, 2) - 1 '学科所在的列
    
17.     d2(crr(1, i)) = i
    
18. Next
    
19. For i = 1 To s
    
20.     Set wb = GetObject(arr(i, 1))
    
21.     zf2 = Split(arr(i, 1), "") '学科
    
22.     zf = Replace(wb.Name, ".xls", "") '考试名称
    
23.     n2 = d2(zf2(UBound(zf2) - 1)) '定位学科所在的列
    
24.     n3 = d2(zf) '考试名称对应的序号
    
25.     brr = wb.Sheets(1).Range("a1").CurrentRegion
    
26.     For j = 2 To UBound(brr)
    
27.         z = zf & "," & brr(j, 1)
    
28.         If Not d.Exists(z) Then
    
29.             n = n + 1
    
30.             d(z) = n
    
31.             crr(n, 1) = zf
    
32.             crr(n, 2) = brr(j, 1)
    
33.             crr(n, n2) = brr(j, 2)
    
34.             crr(n, 5) = n3
    
35.         Else
    
36.             crr(d(z), n2) = brr(j, 2)
    
37.         End If
    
38.     Next
    
39.     wb.Close 0
    
40. Next
    
41. With Range("a1").Resize(n, 5)
    
42.     .Value = crr
    
43.     .Sort [e2], Header:=xlGuess
    
44. End With
    
45. Columns(5).Clear
    
46. Application.ScreenUpdating = True
    
47. End Sub
    
48. Sub Zdir(P)
    
49. Set fs = CreateObject("scripting.filesystemobject")
    
50. For Each f In fs.GetFolder(P).Files
    
51.     s = s + 1
    
52.     arr(s, 1) = f
    
53. Next
    
54. For Each m In fs.GetFolder(P).SubFolders
    
55.     Zdir m
    
56. Next
    
57. End Sub
    

复制代码

liyh67

[em17]