[已解决]按照格式进行成绩汇总,并计算出两列中的人数.谢谢!

心灵之舞

成绩汇总.rar (14.03 KB, 下载次数: 12)

2014-1-8 14:21 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

风林火山

2014-1-8 17:48

1. 
   
2. <P>Sub test()
   
3.     Dim rg As Range, rng As Range
   
4.     Dim k%, m%, i%
   
5.     Dim arr()
   
6. '--------------------------------------------------------------------------------------
   
7.     Set rng = Sheets("数据").Range("a1:a" & Range("a65536").End(3).Row)
   
8. '--------------------------------------------------------------------------------------
   
9.     For Each rg In rng
   
10.         If rg = "组别：" Then
    
11.             brr = rg.CurrentRegion
    
12.             ReDim Preserve arr(1 To 100, 1 To 7)
    
13.             For i = 3 To UBound(brr)
    
14.             k = k + 1
    
15.                 arr(k + 1, 1) = brr(i, 1): arr(k + 1, 2) = brr(i, 5): arr(k + 1, 3) = brr(i, 2)
    
16.                 arr(k + 1, 4) = brr(i, 3): arr(k + 1, 5) = brr(i, 4): arr(k + 1, 6) = rg.Offset(, 1)
    
17.                 If Len(brr(i, 2)) = 0 Then
    
18.                 n = 1 + Len(brr(i, 3)) - Len(Replace(brr(i, 3), " ", ""))
    
19.                 Else
    
20.                 n = 1 + Len(brr(i, 2) & " " & brr(i, 3)) - Len(Replace(brr(i, 2) & " " & brr(i, 3), " ", ""))
    
21.                 End If
    
22.                 arr(k + 1, 7) = n
    
23.             Next i
    
24.         End If
    
25.         Set brr = Nothing
    
26.     Next rg
    
27. '--------------------------------------------------------------------------------------
    
28.     arr(1, 1) = "名次": arr(1, 2) = "背号": arr(1, 3) = "男选手": arr(1, 4) = "女选手"
    
29.     arr(1, 5) = "参赛单位": arr(1, 6) = "组别": arr(1, 7) = "男女选手总人数":
    
30. '--------------------------------------------------------------------------------------
    
31.     Sheets.Add
    
32.     Range("a2").Resize(UBound(arr), 7) = arr
    
33.     Cells.EntireColumn.AutoFit
    
34.     ActiveSheet.Name = "汇总表"</P>
    
35. <P>End Sub
    
36. </P>

复制代码

跳转到最佳答案楼层

CheryBTL

请楼主测试：
成绩汇总.rar (37.17 KB, 下载次数: 11)

2014-1-8 15:40 上传

点击文件名下载附件

风林火山

1. 
   
2. <P>Sub test()
   
3.     Dim rg As Range, rng As Range
   
4.     Dim k%, m%, i%
   
5.     Dim arr()
   
6. '--------------------------------------------------------------------------------------
   
7.     Set rng = Sheets("数据").Range("a1:a" & Range("a65536").End(3).Row)
   
8. '--------------------------------------------------------------------------------------
   
9.     For Each rg In rng
   
10.         If rg = "组别：" Then
    
11.             brr = rg.CurrentRegion
    
12.             ReDim Preserve arr(1 To 100, 1 To 7)
    
13.             For i = 3 To UBound(brr)
    
14.             k = k + 1
    
15.                 arr(k + 1, 1) = brr(i, 1): arr(k + 1, 2) = brr(i, 5): arr(k + 1, 3) = brr(i, 2)
    
16.                 arr(k + 1, 4) = brr(i, 3): arr(k + 1, 5) = brr(i, 4): arr(k + 1, 6) = rg.Offset(, 1)
    
17.                 If Len(brr(i, 2)) = 0 Then
    
18.                 n = 1 + Len(brr(i, 3)) - Len(Replace(brr(i, 3), " ", ""))
    
19.                 Else
    
20.                 n = 1 + Len(brr(i, 2) & " " & brr(i, 3)) - Len(Replace(brr(i, 2) & " " & brr(i, 3), " ", ""))
    
21.                 End If
    
22.                 arr(k + 1, 7) = n
    
23.             Next i
    
24.         End If
    
25.         Set brr = Nothing
    
26.     Next rg
    
27. '--------------------------------------------------------------------------------------
    
28.     arr(1, 1) = "名次": arr(1, 2) = "背号": arr(1, 3) = "男选手": arr(1, 4) = "女选手"
    
29.     arr(1, 5) = "参赛单位": arr(1, 6) = "组别": arr(1, 7) = "男女选手总人数":
    
30. '--------------------------------------------------------------------------------------
    
31.     Sheets.Add
    
32.     Range("a2").Resize(UBound(arr), 7) = arr
    
33.     Cells.EntireColumn.AutoFit
    
34.     ActiveSheet.Name = "汇总表"</P>
    
35. <P>End Sub
    
36. </P>

复制代码

心灵之舞

楼上两位是高手呀，谢谢你们的解答哦