|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("sheet2")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:b" & r)
- ReDim frr(1 To Application.Sum(Application.Index(arr, 0, 2)))
- m = 0
- For i = 1 To UBound(arr)
- For j = 1 To arr(i, 2)
- m = m + 1
- frr(m) = i & "考场" & j & "号座"
- Next
- Next
- End With
- With Worksheets("sheet1")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a1:m" & r)
- ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 5)
- For i = 2 To UBound(arr)
- For j = 4 To 6
- If IsNumeric(arr(i, j)) Then
- brr(i, 1) = brr(i, 1) + arr(i, j)
- End If
- Next
- For j = 7 To UBound(arr, 2)
- If IsNumeric(arr(i, j)) Then
- brr(i, j - 5) = arr(i, j)
- End If
- Next
- Next
- brr(1, 1) = "语数外"
- For j = 7 To UBound(arr, 2)
- brr(1, j - 5) = arr(1, j)
- Next
- ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
- For j = 1 To UBound(brr, 2)
- crr(1, j) = brr(1, j)
- Next
- For j = 1 To UBound(brr, 2)
- d.RemoveAll
- For i = 2 To UBound(brr)
- If Len(brr(i, j)) <> 0 And IsNumeric(brr(i, j)) Then
- d(brr(i, j)) = d(brr(i, j)) + 1
- End If
- Next
- nn = 1
- kk = d.keys
- For k = 0 To UBound(kk)
- mm = Application.Large(kk, k + 1)
- ss = d(mm)
- d(mm) = nn
- nn = nn + ss
- Next
- For i = 2 To UBound(brr)
- If Len(brr(i, j)) <> 0 Then
- crr(i, j) = d(brr(i, j))
- d(brr(i, j)) = d(brr(i, j)) + 1
- End If
- Next
- Next
- ReDim drr(1 To UBound(crr), 1 To UBound(crr, 2) + 3)
- For j = 1 To UBound(crr, 2)
- drr(1, j) = crr(1, j) & "考场"
- Next
- For j = 1 To UBound(crr, 2)
- For i = 2 To UBound(crr)
- If Len(crr(i, j)) <> 0 Then
- drr(i, j) = crr(1, j) & Space(2) & frr(crr(i, j))
- End If
- Next
- Next
- ls = UBound(drr, 2)
- drr(1, ls - 2) = "语数外汇总"
- drr(1, ls - 1) = "7选3汇总"
- drr(1, ls) = "各科考场汇总"
- For i = 2 To UBound(drr)
- drr(i, ls - 2) = drr(i, 1)
- For j = 2 To ls - 3
- If Len(drr(i, j)) <> 0 Then
- If IsEmpty(drr(i, ls - 1)) Then
- drr(i, ls - 1) = drr(i, j)
- Else
- drr(i, ls - 1) = drr(i, ls - 1) & Space(2) & drr(i, j)
- End If
- End If
- Next
- If Len(drr(i, ls - 2)) <> 0 Then
- drr(i, ls) = drr(i, ls - 2)
- End If
- If Len(drr(i, ls - 1)) <> 0 Then
- drr(i, ls) = drr(i, ls) & Space(2) & drr(i, ls - 1)
- End If
- Next
- .Range("o1").Resize(UBound(drr), UBound(drr, 2)) = drr
- End With
- Application.ScreenUpdating = True
- MsgBox "考场安排完毕!"
- End Sub
复制代码 |
评分
-
2
查看全部评分
-
|