|
|
Sub 获取成绩()
Application.ScreenUpdating = False
Dim d As Object
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Set d = CreateObject("scripting.dictionary")
With Sheets("原数据")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:m" & r)
End With
With Sheets("标签")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
.Rows("11:" & rs + 11).Delete
sl = r - 1
If sl / 3 = Int(sl / 3) Then
m = sl / 3
Else
m = Int(sl / 3) + 1
End If
ws = 11
For i = 1 To m
.Rows("1:10").Copy .Cells(ws, 1)
ws = ws + 10
Next i
m = 3
xh = 1
On Error Resume Next
For i = 2 To UBound(ar) Step 3
If Trim(ar(i, 2)) <> "" Then
n = 0
ReDim br(1 To UBound(ar, 2), 1 To 1)
ReDim cr(1 To UBound(ar, 2), 1 To 1)
For j = 3 To UBound(ar, 2) Step 2
If Trim(ar(i, j)) <> "" Then
n = n + 1
br(n, 1) = ar(i, j)
cr(n, 1) = ar(i, j + 1)
End If
Next j
.Cells(m, 1) = xh
.Cells(m, 4) = ar(i, 2)
.Cells(m + 1, 2).Resize(n, 1) = br
.Cells(m + 1, 5).Resize(n, 1) = cr
.Cells(m + 6, 2) = ar(i, 13)
End If
If Trim(ar(i + 1, 2)) <> "" Then
n = 0
ReDim br(1 To UBound(ar, 2), 1 To 1)
ReDim cr(1 To UBound(ar, 2), 1 To 1)
For j = 3 To UBound(ar, 2) Step 2
If Trim(ar(i + 1, j)) <> "" Then
n = n + 1
br(n, 1) = ar(i + 1, j)
cr(n, 1) = ar(i + 1, j + 1)
End If
Next j
.Cells(m, 8) = xh + 1
.Cells(m, 11) = ar(i + 1, 2)
.Cells(m + 1, 9).Resize(n, 1) = br
.Cells(m + 1, 12).Resize(n, 1) = cr
.Cells(m + 6, 9) = ar(i + 1, 13)
End If
If Trim(ar(i + 2, 2)) <> "" Then
n = 0
ReDim br(1 To UBound(ar, 2), 1 To 1)
ReDim cr(1 To UBound(ar, 2), 1 To 1)
For j = 3 To UBound(ar, 2) Step 2
If Trim(ar(i + 2, j)) <> "" Then
n = n + 1
br(n, 1) = ar(i + 2, j)
cr(n, 1) = ar(i + 2, j + 1)
End If
Next j
.Cells(m, 15) = xh + 2
.Cells(m, 18) = ar(i + 2, 2)
.Cells(m + 1, 16).Resize(n, 1) = br
.Cells(m + 1, 19).Resize(n, 1) = cr
.Cells(m + 6, 16) = ar(i + 2, 13)
End If
m = m + 10
xh = xh + 3
Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2021-10-8 14:07
楼主
