|
Sub 填表()
Application.ScreenUpdating = False
Dim ar As Variant
ReDim arr(1 To Sheets.Count)
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "数据源为空!": End
ar = .Range("a1:ak" & r)
End With
With Sheets("分表")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If rs >= 35 Then .Rows("35:" & rs).Delete
m = 35
For i = 2 To UBound(ar) - 1
.Rows("1:34").Copy .Cells(m, 1)
m = m + 34
Next i
m = 2
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) <> "" Then
.Cells(m, 2) = ar(i, 1)
.Cells(m, 4) = ar(i, 2)
xh = m + 2
.Cells(xh, 6) = ar(i, 7)
.Cells(xh + 4, 6) = ar(i, 15)
.Cells(xh + 11, 6) = ar(i, 28)
.Cells(xh + 24, 6) = ar(i, 32)
.Cells(xh + 27, 6) = ar(i, 35)
.Cells(xh + 29, 6) = ar(i, 36)
.Cells(xh + 30, 6) = ar(i, 37)
For j = 3 To UBound(ar, 2) - 3
If InStr(ar(1, j), "★") = 0 Then
xh = xh + 1
.Cells(xh, 5) = ar(i, j)
End If
Next j
m = m + 34
End If
Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|