|
|
代码重新调整了一下，嘿嘿。
Private Sub CommandButton1_Click()
Dim Sh, xi, jg, d As Integer
Dim Row1, Arr1, Arr2, Arr11
Sh = Val(TextBox1.Text)
xi = Val(TextBox2.Text)
jg = Val(TextBox3.Text)
d = (Sh - xi) / jg
Row1 = Sheets("成绩表").Range("B65536").End(xlUp).Row
Arr1 = Sheets("成绩表").Range("a2:B" & Row1)
Set r = Sheets("成绩表").Range("a2:a" & Row1)
If TextBox1.Text = "" Or TextBox2.Text = "" Then
MsgBox ("上、下限未全部设置"): Exit Sub
Else
Application.ScreenUpdating = False
Cells.Clear
If zx.Value = True Then
'Columns(4).Insert
Cells(1, 3) = "班级"
Cells(1, 4) = Sh & "以上"
For i = 1 To d
Cells(1, 4 + i) = (Sh - jg * i) & "≤x<" & (Sh - jg * (i - 1))
Next i
Cells(1, 5 + d) = xi & "以下"
Set dic = CreateObject("scripting.dictionary")
For Each rng In r
tmp = rng.Value
If dic.exists(tmp) Then
dic(tmp) = dic(tmp) + 1
Else
dic.Add tmp, 1
End If
Next
Cells(2, 3).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
Cells(2, 3).Resize(dic.Count, 1).Sort key1:=Cells(2, 3), order1:=xlAscending, HEADER:=xlNo
Arr2 = Range("c2:c" & (1 + dic.Count))
ReDim Arr11(1 To UBound(Arr2), 1 To d + 2)
For i = 1 To UBound(Arr2)
For k = 1 To d + 2
w = 0
For j = 1 To UBound(Arr1)
If k = 1 Then
If Arr1(j, 1) = Arr2(i, 1) And Arr1(j, 2) >= Sh Then w = w + 1
End If
If k = d + 2 Then
If Arr1(j, 1) = Arr2(i, 1) And Arr1(j, 2) < xi Then w = w + 1
End If
If k > 1 And k < d + 2 Then
If Arr1(j, 1) = Arr2(i, 1) And Arr1(j, 2) >= (Sh - jg * (k - 1)) And Arr1(j, 2) < (Sh - jg * (k - 2)) Then w = w + 1
End If
Next j
Arr11(i, k) = w
Next k
Next i
Cells(2, 4).Resize(dic.Count, d + 2) = Arr11
End If
If hx.Value = True Then
Cells(1, 3) = "班级"
Cells(2, 3) = Sh & "以上"
For i = 1 To d
Cells(i + 2, 3) = (Sh - jg * i) & "≤x<" & (Sh - jg * (i - 1))
Next i
Cells(3 + d, 3) = xi & "以下"
Set dic = CreateObject("scripting.dictionary")
For Each rng In r
tmp = rng.Value
If dic.exists(tmp) Then
dic(tmp) = dic(tmp) + 1
Else
dic.Add tmp, 1
End If
Next
Cells(1, 4).Resize(1, dic.Count) = (dic.keys)
With Cells(1, 4).Resize(1, dic.Count)
For i = 0 To dic.Count - 1
.Offset(i, 0).Sort key1:=Cells(1, 4).Offset(i, 0), order1:=xlAscending, Orientation:=xlLeftToRight
Next
End With
Arr2 = Cells(1, 4).Resize(1, dic.Count)
ReDim Arr2(1 To dic.Count)
For i = 1 To dic.Count '填写班级
Arr2(i) = Cells(1, i + 3)
Next i
ReDim Arr11(1 To UBound(Arr2), 1 To d + 2)
For i = 1 To UBound(Arr2)
For k = 1 To d + 2
w = 0
For j = 1 To UBound(Arr1)
If k = 1 Then
If Arr1(j, 1) = Arr2(i) And Arr1(j, 2) >= Sh Then w = w + 1
End If
If k = d + 2 Then
If Arr1(j, 1) = Arr2(i) And Arr1(j, 2) < xi Then w = w + 1
End If
If k > 1 And k < d + 2 Then
If Arr1(j, 1) = Arr2(i) And Arr1(j, 2) >= (Sh - jg * (k - 1)) And Arr1(j, 2) < (Sh - jg * (k - 2)) Then w = w + 1
End If
Next j
Arr11(i, k) = w
Next k
Next i
Cells(2, 4).Resize(d + 2, dic.Count) = Application.Transpose(Arr11)
End If
End If
Cells.ColumnWidth = 4.25
Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
Me.Hide
End Sub
|
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-8-7 21:58
楼主
