求助：用VBA提取数据并进行排名

longkkkk

wuchengde 发表于 2019-4-19 21:25
是的，只统计所选年级的，其他不用管，排序排不排都没关系，排序我可以根据总分进行排的，要是能一起考虑 ...

明天试试，应该可以

wuchengde

mjzxlmg 发表于 2019-4-19 21:28
关键是这种没有规律的表格写出来的代码通用性不强呀。同是科目，语文跟其它科目不同， 科目顺序乱了判断太 ...

没办法啊，领导要将语文的基础知识和作文分开来看啊，我也头痛啊。

wuchengde

longkkkk 发表于 2019-4-19 21:30
明天试试，应该可以

非常感谢您的帮助。

wuchengde

mjzxlmg 发表于 2019-4-19 21:28
关键是这种没有规律的表格写出来的代码通用性不强呀。同是科目，语文跟其它科目不同， 科目顺序乱了判断太 ...

科目顺序固定为：语文、数学、英语、科学、品德

不会变位置的。

longkkkk

1. Option Explicit
   
2. Sub 主程序()
   
3.     Dim sht As Worksheet
   
4.     For Each sht In Sheets
   
5.         If sht.Name = "成绩总表(" & Sheets("基本信息设置").Range("d2").Value & ")" Then
   
6.             If MsgBox("该表已存在,是否覆盖?", 33, "提醒！") = vbOK Then
   
7.                 Application.DisplayAlerts = False
   
8.                 Sheets("成绩总表(" & Sheets("基本信息设置").Range("d2").Value & ")").Delete
   
9.                 Application.DisplayAlerts = True
   
10.                 Exit For
    
11.             Else
    
12.                 Exit Sub
    
13.             End If
    
14.         End If
    
15.     Next
    
16.     Call 生成年级成绩
    
17. End Sub
    
18. 
    
19. 
    
20. Sub 生成年级成绩()
    
21.     Dim i, r, arow&
    
22.    
    
23.     Call 清除格式
    
24.    
    
25.     Sheets("mb").Copy after:=Sheets("基本信息设置")
    
26.     ActiveSheet.Name = "成绩总表(" & Sheets("基本信息设置").Range("d2").Value & ")"
    
27.     Application.ScreenUpdating = False
    
28.     r = 5
    
29.     For i = 4 To Sheets("原始成绩").Range("a" & Rows.Count).End(xlUp).Row
    
30.         If Sheets("原始成绩").Range("C" & i).Value = Left(Sheets("基本信息设置").Range("d2").Value, 1) Then
    
31.              Range("A" & r).Value = Sheets("原始成绩").Range("B" & i).Value
    
32.              Range("B" & r).Value = Sheets("原始成绩").Range("C" & i).Value
    
33.              Range("C" & r).Value = Sheets("原始成绩").Range("D" & i).Value
    
34.              Range("D" & r).Value = Sheets("原始成绩").Range("E" & i).Value
    
35.              Range("E" & r).Value = Sheets("原始成绩").Range("F" & i).Value
    
36.              Range("F" & r).Value = Sheets("原始成绩").Range("G" & i).Value
    
37.              Range("J" & r).Value = Sheets("原始成绩").Range("H" & i).Value
    
38.              Range("N" & r).Value = Sheets("原始成绩").Range("I" & i).Value
    
39.              Range("A" & r).Value = Sheets("原始成绩").Range("B" & i).Value
    
40.              Range("R" & r).Value = Sheets("原始成绩").Range("J" & i).Value
    
41.              Range("V" & r).Value = Sheets("原始成绩").Range("K" & i).Value
    
42.              Range("Z" & r).Value = Sheets("原始成绩").Range("L" & i).Value
    
43.              Range("AD" & r).Value = Sheets("原始成绩").Range("M" & i).Value
    
44.              Range("AH" & r).Value = Sheets("原始成绩").Range("N" & i).Value
    
45.              Range("AL" & r).Value = Sheets("原始成绩").Range("O" & i).Value
    
46.              r = r + 1
    
47.         End If
    
48.     Next
    
49.    
    
50.     arow = Range("a" & Rows.Count).End(xlUp).Row
    
51.    
    
52.     Range("A5:AO" & arow).Select
    
53.    
    
54.     With Selection.Borders(xlEdgeLeft)
    
55.         .LineStyle = xlContinuous
    
56.         .Weight = xlThin
    
57.     End With
    
58.     With Selection.Borders(xlEdgeTop)
    
59.         .LineStyle = xlContinuous
    
60.         .Weight = xlThin
    
61.     End With
    
62.     With Selection.Borders(xlEdgeBottom)
    
63.         .LineStyle = xlContinuous
    
64.         .Weight = xlThin
    
65.     End With
    
66.     With Selection.Borders(xlEdgeRight)
    
67.         .LineStyle = xlContinuous
    
68.         .Weight = xlThin
    
69.     End With
    
70.     With Selection.Borders(xlInsideVertical)
    
71.         .LineStyle = xlContinuous
    
72.         .Weight = xlThin
    
73.     End With
    
74.     With Selection.Borders(xlInsideHorizontal)
    
75.         .LineStyle = xlContinuous
    
76.         .Weight = xlThin
    
77.     End With
    
78.    
    
79.     With Selection
    
80.         .HorizontalAlignment = xlCenter
    
81.         .VerticalAlignment = xlCenter
    
82.     End With
    
83.    
    
84.         For i = 5 To arow
    
85.             Range("G" & i).Value = Application.WorksheetFunction.Rank(Range("F" & i).Value, Range("F" & uprow(Range("C" & i)) & ":F" & downrow(Range("C" & i))), 0)          '班级排名
    
86.             Range("K" & i).Value = Application.WorksheetFunction.Rank(Range("J" & i).Value, Range("J" & uprow(Range("C" & i)) & ":J" & downrow(Range("C" & i))), 0)
    
87.             Range("O" & i).Value = Application.WorksheetFunction.Rank(Range("N" & i).Value, Range("N" & uprow(Range("C" & i)) & ":N" & downrow(Range("C" & i))), 0)
    
88.             Range("S" & i).Value = Application.WorksheetFunction.Rank(Range("R" & i).Value, Range("R" & uprow(Range("C" & i)) & ":R" & downrow(Range("C" & i))), 0)
    
89.             Range("AI" & i).Value = Application.WorksheetFunction.Rank(Range("AH" & i).Value, Range("AH" & uprow(Range("C" & i)) & ":AH" & downrow(Range("C" & i))), 0)
    
90.             Range("AM" & i).Value = Application.WorksheetFunction.Rank(Range("AL" & i).Value, Range("AL" & uprow(Range("C" & i)) & ":AL" & downrow(Range("C" & i))), 0)
    
91.             
    
92.             Range("H" & i).Value = Application.WorksheetFunction.Rank(Range("F" & i).Value, Range("F" & uprow(Range("A" & i)) & ":F" & downrow(Range("A" & i))), 0)          '校级排名
    
93.             Range("L" & i).Value = Application.WorksheetFunction.Rank(Range("J" & i).Value, Range("J" & uprow(Range("A" & i)) & ":J" & downrow(Range("A" & i))), 0)
    
94.             Range("P" & i).Value = Application.WorksheetFunction.Rank(Range("N" & i).Value, Range("N" & uprow(Range("A" & i)) & ":N" & downrow(Range("A" & i))), 0)
    
95.             Range("T" & i).Value = Application.WorksheetFunction.Rank(Range("R" & i).Value, Range("R" & uprow(Range("A" & i)) & ":R" & downrow(Range("A" & i))), 0)
    
96.             Range("AJ" & i).Value = Application.WorksheetFunction.Rank(Range("AH" & i).Value, Range("AH" & uprow(Range("A" & i)) & ":AH" & downrow(Range("A" & i))), 0)
    
97.             Range("AN" & i).Value = Application.WorksheetFunction.Rank(Range("AL" & i).Value, Range("AL" & uprow(Range("A" & i)) & ":AL" & downrow(Range("A" & i))), 0)
    
98.             
    
99.             Range("I" & i).Value = Application.WorksheetFunction.Rank(Range("F" & i).Value, Range("F5:F" & arow), 0)                                                          '总排名
    
100.             Range("M" & i).Value = Application.WorksheetFunction.Rank(Range("J" & i).Value, Range("J5:J" & arow), 0)
     
101.             Range("Q" & i).Value = Application.WorksheetFunction.Rank(Range("N" & i).Value, Range("N5:N" & arow), 0)
     
102.             Range("U" & i).Value = Application.WorksheetFunction.Rank(Range("R" & i).Value, Range("R5:R" & arow), 0)
     
103.             Range("AK" & i).Value = Application.WorksheetFunction.Rank(Range("AH" & i).Value, Range("AH5:AH" & arow), 0)
     
104.             Range("AO" & i).Value = Application.WorksheetFunction.Rank(Range("AL" & i).Value, Range("AL5:AL" & arow), 0)
     
105.         Next
     
106.    
     
107.    
     
108.     If Sheets("基本信息设置").Range("d2").Value <> "一年级" And Sheets("基本信息设置").Range("d2").Value <> "二年级" Then
     
109.         
     
110.         For i = 5 To arow
     
111.            
     
112.             Range("W" & i).Value = Application.WorksheetFunction.Rank(Range("V" & i).Value, Range("V" & uprow(Range("C" & i)) & ":V" & downrow(Range("C" & i))), 0)
     
113.             Range("AA" & i).Value = Application.WorksheetFunction.Rank(Range("Z" & i).Value, Range("Z" & uprow(Range("C" & i)) & ":Z" & downrow(Range("C" & i))), 0)
     
114.             Range("AE" & i).Value = Application.WorksheetFunction.Rank(Range("AD" & i).Value, Range("AD" & uprow(Range("C" & i)) & ":AD" & downrow(Range("C" & i))), 0)
     
115.            
     
116.             Range("X" & i).Value = Application.WorksheetFunction.Rank(Range("V" & i).Value, Range("V" & uprow(Range("A" & i)) & ":V" & downrow(Range("A" & i))), 0)
     
117.             Range("AB" & i).Value = Application.WorksheetFunction.Rank(Range("Z" & i).Value, Range("Z" & uprow(Range("A" & i)) & ":Z" & downrow(Range("A" & i))), 0)
     
118.             Range("AF" & i).Value = Application.WorksheetFunction.Rank(Range("AD" & i).Value, Range("AD" & uprow(Range("A" & i)) & ":AD" & downrow(Range("A" & i))), 0)
     
119.          
     
120.             Range("Y" & i).Value = Application.WorksheetFunction.Rank(Range("V" & i).Value, Range("V5:V" & arow), 0)
     
121.             Range("AC" & i).Value = Application.WorksheetFunction.Rank(Range("Z" & i).Value, Range("Z5:Z" & arow), 0)
     
122.             Range("AG" & i).Value = Application.WorksheetFunction.Rank(Range("AD" & i).Value, Range("AD5:AD" & arow), 0)
     
123.         
     
124.         Next
     
125.     Else
     
126.         Columns("V:AG").Delete
     
127.         
     
128.     End If
     
129.     Application.ScreenUpdating = True
     
130.     Range("A5").Select
     
131. End Sub
     
132. 
     
133. Function uprow(ByVal aaa As Range)
     
134.     Dim h, l, i&
     
135.     h = aaa.Row
     
136.     l = aaa.Column
     
137.     For i = aaa.Row To 1 Step -1
     
138.         If aaa.Value <> Cells(i, l).Value Then Exit For
     
139.     Next
     
140.     uprow = i + 1
     
141. End Function
     
142. 
     
143. Function downrow(ByVal aaa As Range)
     
144.     Dim h, l, i&
     
145.     h = aaa.Row
     
146.     l = aaa.Column
     
147.     For i = aaa.Row To Rows.Count
     
148.         If aaa.Value <> Cells(i, l).Value Then Exit For
     
149.     Next
     
150.     downrow = i - 1
     
151. End Function
     
152. 
     
153. Sub 清除格式()
     
154. Dim s As Style
     
155. Application.ScreenUpdating = False
     
156. On Error Resume Next
     
157. For Each s In ThisWorkbook.Styles
     
158.     If Not s.BuiltIn Then s.Delete
     
159. Next
     
160. Application.ScreenUpdating = True
     
161. End Sub
     
162. 
     

复制代码

我也是新手，刚刚学习VBA，可能写得比较啰嗦，你看看可不可以用

乐乐2006201505

wuchengde 发表于 2019-4-19 20:10
Sheets.Add
ActiveSheet.Name = s
Sheets(s).Activate

这个代码不全啊！

wuchengde

longkkkk 发表于 2019-4-20 01:55
我也是新手，刚刚学习VBA，可能写得比较啰嗦，你看看可不可以用

非常感谢你大半夜能帮忙解决问题，由于今天外出，晚上再测试一下是否能达到目的

wuchengde

乐乐2006201505 发表于 2019-4-20 07:05
这个代码不全啊！

由于不是同一个问题，所以去除了上面部分的定义。但主要代码还是在的，主要是班排和年排子程序……

yjh_27

班排和年排子程序可参见
通用排名次自定义函数
http://club.excelhome.net/thread-1454513-1-1.html
(出处: ExcelHome技术论坛)

mjzxlmg

wuchengde 发表于 2019-4-19 18:11
补传附件，希望各位高手帮忙解决，非常感谢！

XX中心考试各学校成绩表(2).rar (47.93 KB, 下载次数: 28)

2019-4-20 21:40 上传

点击文件名下载附件