|
楼主 |
发表于 2018-2-19 21:04
|
显示全部楼层
Sub lqxs()
Dim arr, i&, aa, j&, n&, m&, col%, ks&
Dim d, k, t, d1
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Sheet1.Activate: n = 1
[a2:m500].ClearContents
arr = Sheet2.[a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 5) <> "" Then
d(arr(i, 5)) = d(arr(i, 5)) & i & ","
Else
If d(arr(i, 3)) <> "" And IsNumeric(arr(i, 3)) Then d(arr(i, 3) & "年级") = d(arr(i, 3) & "年级") & i & ","
End If
Next
k = d.keys: t = d.items
For i = 0 To UBound(k)
n = n + 1: col = 2: m = 0
Cells(n, 2) = k(i): ks = n
t(i) = Left(t(i), Len(t(i)) - 1)
If InStr(t(i), ",") Then
aa = Split(t(i), ",")
For j = 0 To UBound(aa)
If Not d1.exists(arr(aa(j), 2)) Then
d1(arr(aa(j), 2)) = ""
col = col + 1: m = m + 1
If col > 13 Then col = 3: n = n + 1
Cells(n, col) = arr(aa(j), 2)
End If
Next
Cells(ks, 1) = m
Else
Cells(n, 3) = arr(t(i), 2): Cells(n, 1) = 1
End If
Next
End Sub
|
|