[已解决]请老师指教,这个用VBA可以实现吗?

huangjinyui

请老师指教,这个用VBA可以实现吗?

最佳答案

月排行榜 / 总排行榜

liuguansky

2011-12-8 08:50

huangjinyui 发表于 2011-12-8 08:35
感谢iuguansky 老师，可这样就不能按男女分组提取生成了，该怎样弄才成呢？

看附件吧： 运动会.rar (17.34 KB, 下载次数: 7)

2011-12-8 08:50 上传

点击文件名下载附件

跳转到最佳答案楼层

liuguansky

1. 
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     If Target.Address(0, 0) = "C1" Then
   
4.         Dim Arr, i&, ArrR(1 To 10000, 1 To 9)
   
5.         Dim j As Byte, M&, N&, S As Byte
   
6.         With Sheet1
   
7.             Arr = .Range("A2:n" & .Cells(.Rows.Count, 1).End(3).Row).Value
   
8.         End With
   
9.         For i = 3 To UBound(Arr)
   
10.             If Arr(i, 1) = Target.Value Then
    
11.                 S = 0
    
12.                 If Arr(i, 3) = "男" Then
    
13.                     M = M + 1
    
14.                     ArrR(M, 1) = Arr(i, 2)
    
15.                     For j = 4 To UBound(Arr, 2)
    
16.                         If Len(Arr(i, j)) Then
    
17.                             S = S + 1
    
18.                             ArrR(M, S + 1) = Arr(1, j)
    
19.                         End If
    
20.                     Next j
    
21.                 Else
    
22.                     N = N + 1
    
23.                     ArrR(N, 6) = Arr(i, 2)
    
24.                     For j = 4 To UBound(Arr, 2)
    
25.                         If Len(Arr(i, j)) Then
    
26.                             S = S + 1
    
27.                             ArrR(N, S + 6) = Arr(1, j)
    
28.                         End If
    
29.                     Next j
    
30.                 End If
    
31.             End If
    
32.         Next i
    
33.         Range("a4:i" & Rows.Count).Clear
    
34.         M = Application.Max(M, N)
    
35.         If M > 0 Then Range("A4").Resize(M, 9) = ArrR
    
36.     End If
    
37. End Sub

复制代码

运动会.rar (13.93 KB, 下载次数: 15)

2011-12-7 19:40 上传

点击文件名下载附件

菜鸟锐

2楼的是高手啊！！！！拜服！！！

huangjinyui

liuguansky 发表于 2011-12-7 19:37

非常感谢老师，辛苦了！
　　想再麻烦老师，若我在一页面里面要有3个班，该怎样修改才可以呢！

谢谢

liuguansky

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Not Application.Intersect(Target, Range("c1,c12,c23")) Is Nothing Then
   
3.         Dim Arr, i&, ArrR(1 To 10000, 1 To 9)
   
4.         Dim j As Byte, M&, N&, S As Byte
   
5.         With Sheet1
   
6.             Arr = .Range("A2:n" & .Cells(.Rows.Count, 1).End(3).Row).Value
   
7.         End With
   
8.         For i = 3 To UBound(Arr)
   
9.             If Arr(i, 1) = Target.Value Then
   
10.                 S = 0
    
11.                 If Arr(i, 3) = "ÄÐ" Then
    
12.                     M = M + 1
    
13.                     ArrR(M, 1) = Arr(i, 2)
    
14.                     For j = 4 To UBound(Arr, 2)
    
15.                         If Len(Arr(i, j)) Then
    
16.                             S = S + 1
    
17.                             ArrR(M, S + 1) = Arr(1, j)
    
18.                         End If
    
19.                     Next j
    
20.                 Else
    
21.                     N = N + 1
    
22.                     ArrR(N, 6) = Arr(i, 2)
    
23.                     For j = 4 To UBound(Arr, 2)
    
24.                         If Len(Arr(i, j)) Then
    
25.                             S = S + 1
    
26.                             ArrR(N, S + 6) = Arr(1, j)
    
27.                         End If
    
28.                     Next j
    
29.                 End If
    
30.             End If
    
31.         Next i
    
32.         With Cells(Target.Row + 3, 1)
    
33.             .Resize(8, 9).Clear
    
34.             M = Application.Min(8, Application.Max(M, N))
    
35.             If M > 0 Then .Resize(M, 9) = ArrR
    
36.         End With
    
37.     End If
    
38. End Sub

复制代码

这样试试

huangjinyui

liuguansky 发表于 2011-12-7 22:48
这样试试

感谢iuguansky 老师，可这样就不能按男女分组提取生成了，该怎样弄才成呢？

liuguansky

huangjinyui 发表于 2011-12-8 08:35
感谢iuguansky 老师，可这样就不能按男女分组提取生成了，该怎样弄才成呢？

看附件吧： 运动会.rar (17.34 KB, 下载次数: 7)

2011-12-8 08:50 上传

点击文件名下载附件