Option Explicit
Sub TEST()
Dim Arr, i&, xA As Range, N&, xT1, xT2, Ln%
Arr = Range([名冊!B2], [名冊!A65536].End(3))
Set xT1 = Sheets("胸牌").Shapes("編號_1").TextFrame2.TextRange.Characters
With Sheets("結果")
With .DrawingObjects
If .Count > 0 Then .Delete
End With
Set xA = .[A1].Resize(UBound(Arr) \ 9 + 1, 9)
xA.EntireRow.RowHeight = [胸牌!A1].RowHeight
xA.EntireColumn.ColumnWidth = [胸牌!A1].ColumnWidth
End With
For i = 1 To UBound(Arr)
N = N + 1
xT1.Text = Arr(i, 2)
Ln = Switch(Len(Arr(i, 2)) <= 3, 36, Len(Arr(i, 2)) = 4, 28, Len(Arr(i, 2)) = 5, 24)
Sheets("胸牌").Shapes("編號_1").TextFrame2.TextRange.Font.Size = Ln
[胸牌!A1].Copy xA(N)
Next
xT1.Text = ""
Application.Goto [結果!A1]
End Sub
發表於 
