Andy2483

¦^´_ 1# dou10801


    ¥H¤U½Ð¸Õ¸Õ¬Ý

Option Explicit
Sub TEST()
Dim Arr, i&, xA As Range, N&, xT1, xT2, Ln%
Arr = Range([¦W¥U!B2], [¦W¥U!A65536].End(3))
Set xT1 = Sheets("¯ÝµP").Shapes("½s¸¹_1").TextFrame2.TextRange.Characters
With Sheets("µ²ªG")
   With .DrawingObjects
      If .Count > 0 Then .Delete
   End With
   Set xA = .[A1].Resize(UBound(Arr) \ 9 + 1, 9)
   xA.EntireRow.RowHeight = [¯ÝµP!A1].RowHeight
   xA.EntireColumn.ColumnWidth = [¯ÝµP!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("¯ÝµP").Shapes("½s¸¹_1").TextFrame2.TextRange.Font.Size = Ln
   [¯ÝµP!A1].Copy xA(N)
Next
xT1.Text = ""
Application.Goto [µ²ªG!A1]
End Sub