|
Option Explicit
Sub TEST1()
Dim ar, br, cr, i&, j&, n&, dic(1) As New Dictionary, vKey, Rng As Range, iPosRow&
Application.ScreenUpdating = False
ar = Sheets("班主任").[A1].CurrentRegion.Value
For i = 2 To UBound(ar)
dic(0)(ar(i, 1)) = Array(ar(i, 2), ar(i, 3))
Next i
ar = Sheets("报名表").[A1].CurrentRegion.Value
Set Rng = Sheets("模板").[A1:L34]
For i = 3 To UBound(ar)
dic(1)(ar(i, 4)) = dic(1)(ar(i, 4)) & " " & i
Next i
Cells.Delete
For Each vKey In dic(1).keys
cr = Split(dic(1)(vKey))
ReDim br(1 To UBound(cr), 1 To 4)
For i = 1 To UBound(br)
For j = 1 To UBound(br, 2)
br(i, j) = ar(cr(i), j + 1)
Next j
Next i
br = cutArray(br, 30)
n = n + 1
iPosRow = (n - 1) * 34 + 1
rngCopyToSame Rng, Cells(iPosRow, 1)
If n > 1 Then ActiveSheet.HPageBreaks.Add Before:=Cells(iPosRow, 1)
With Cells(iPosRow, 1)
If dic(0).exists(vKey) Then
.Cells(2, 3).Value = dic(0)(vKey)(0)
.Cells(2, 9).Value = dic(0)(vKey)(1)
End If
For j = 1 To UBound(br)
.Cells(4, (j - 1) * 6 + 2).Resize(UBound(br(j)), UBound(br(j), 2)) = br(j)
Next j
End With
Next
Erase dic
Application.ScreenUpdating = True
Beep
End Sub
Function cutArray(ByVal ar, iCutNum&) As Variant
Dim br(), cr, i&, j&, iPosRow&, r&, k&
For i = 1 To UBound(ar) Step iCutNum
iPosRow = IIf((i + iCutNum - 1) > UBound(ar), UBound(ar) Mod iCutNum, iCutNum)
ReDim cr(1 To iPosRow, 1 To UBound(ar, 2))
For j = 1 To UBound(cr)
For k = 1 To UBound(cr, 2)
cr(j, k) = ar(i - 1 + j, k)
Next k
Next j
r = r + 1
ReDim Preserve br(1 To r)
br(r) = cr
Next i
cutArray = br
End Function
Function rngCopyToSame(ByVal rngSel As Range, ByVal rngTarget As Range)
Dim i&
rngSel.Copy
rngTarget.PasteSpecial xlPasteColumnWidths
rngSel.Copy rngTarget
With rngTarget.Resize(rngSel.Rows.Count, rngSel.Columns.Count)
For i = 1 To .Rows.Count
.Rows(i).RowHeight = rngSel.Rows(i).RowHeight
Next i
End With
End Function
|
评分
-
1
查看全部评分
-
|