|
|
Sub 个人课表()
Dim m, s, i, j, x, k, t, arr, brr, crr(1 To 5, 1 To 9), sa
Dim d As Object, dx As Object
Set d = CreateObject("scripting.dictionary")
Set dx = CreateObject("scripting.dictionary")
sa = Array("一", "二", "三", "四", "五")
Sheet2.Range("C4:K8") = ""
For i = 0 To 4
dx(sa(i)) = i + 1
Next
arr = Sheet1.Range("A1").CurrentRegion
For i = 2 To UBound(arr)
For j = 4 To UBound(arr, 2)
If Len(arr(i, j)) > 2 Then
s = Right(arr(i, j), 2)
If Not d.exists(s) Then
m = 1
ReDim brr(1 To 3, 1 To m)
Else
brr = d(s)
m = UBound(brr, 2) + 1
ReDim Preserve brr(1 To 3, 1 To m)
End If
brr(1, m) = dx(arr(i, 1))
brr(2, m) = j - 3
brr(3, m) = arr(i, 2) & " " & Trim(Mid(arr(i, j), 1, Len(arr(i, j)) - 2))
d(s) = brr
End If
Next
Next
k = d.keys
t = d.items
a = Sheet2.Range("K2")
For x = 0 To d.Count - 1
If k(x) = a Then
For i = 1 To UBound(t(x), 2)
crr(t(x)(1, i), t(x)(2, i)) = t(x)(3, i)
Next
End If
Next
Sheet2.Range("C4").Resize(5, 9) = crr
Set d = Nothing
Set dx = Nothing
End Sub |
|
