Sub 统计全部() |
Dim arr, arr1(), brr, crr, drr, err(), frr() |
Dim i, j, k, x, y, n, m |
Dim rng As Range, rng1 As Range |
Dim d As Object , d1 As Object , d2 As Object |
Dim str As String |
Set d = CreateObject( "Scripting.Dictionary" ) |
Set d1 = CreateObject( "Scripting.Dictionary" ) |
Set d2 = CreateObject( "Scripting.Dictionary" ) |
drr = [{ "高一" , "高二" , "高三" }] |
For i = LBound(drr) To UBound(drr) |
Set rng = Sheets(drr(i)).UsedRange |
x = rng.Range( "f5" ).CurrentRegion.Rows.Count |
y = rng.Range( "f5" ).CurrentRegion.Columns.Count |
For Each rng1 In rng |
If drr(i) = "高一" Then |
If rng1 = "班级" Then |
arr = rng1.CurrentRegion '教师数组 |
End If |
If rng1 = "课时" Then |
brr = rng1.CurrentRegion '课时数组 |
End If |
Else |
If rng1 = "班级" Then |
arr = Range(rng1.CurrentRegion.Cells(1, 2), rng1.CurrentRegion.Cells(x, y)) '教师数组,去掉首列 |
End If |
If rng1 = "课时" Then |
brr = Range(rng1.CurrentRegion.Cells(1, 2), rng1.CurrentRegion.Cells(x, y)) '课时数组,去掉首列 |
End If |
End If |
Next |
k = k + UBound(arr, 2) '计算重定义数组的列数 |
'将数据全部放入数组err和frr |
ReDim Preserve err(1 To UBound(arr), 1 To k) |
ReDim Preserve frr(1 To UBound(arr), 1 To k) |
For m = 1 To UBound(arr, 2) |
n = n + 1 '计数累加 |
For j = 1 To UBound(arr) |
err(j, n) = arr(j, m) |
frr(j, n) = brr(j, m) |
Next |
Next |
Next |
'写入字典去重计数 |
For j = 4 To UBound(err) '循环行 |
For m = 2 To UBound(err, 2) '循环列 |
If err(j, m) <> "" Then |
str = err(j, m) & "##" & err(j, 1) |
If d.exists(str) Then |
d.Item(str) = d.Item(str) + 1 |
d1.Item(str) = d1.Item(str) + frr(j, m) |
d2.Item(str) = d2.Item(str) & "/" & err(2, m) |
Else |
d.Add str, 1 |
d1.Add str, frr(j, m) |
d2.Add str, err(2, m) |
End If |
End If |
Next |
Next |
crr = d.keys '将教师及学科装入数组crr方便分列到arr1 |
ReDim arr1(LBound(crr) To UBound(crr), 1 To 3) |
For i = LBound(crr) To UBound(crr) |
arr1(i, 1) = i + 1 '增加序号 |
arr1(i, 2) = Split(crr(i), "##" )(0) '教师姓名 |
arr1(i, 3) = Split(crr(i), "##" )(1) '任教学科 |
Next |
With Sheets( "统计" ) |
.Cells.Clear '清空统计表 |
.Range( "a1" ).Resize(1, 6) = [{ "序号" , "教师" , "学科" , "班级数" , "课时数" , "对应班级" }] |
.Range( "a2" ).Resize(d.Count, 3) = arr1 '填入序号,教师,学科 |
.Range( "d2" ).Resize(d.Count) = Application.Transpose(d.items) '填入班级数 |
.Range( "e2" ).Resize(d.Count) = Application.Transpose(d1.items) '填入课时数 |
.Range( "f:f" ).NumberFormatLocal = "@" '设置文本格式 |
.Range( "f2" ).Resize(d.Count) = Application.Transpose(d2.items) '填入对应班级 |
End With |
|
|
End Sub |