'上次写过,稍作修改:
Option Explicit
Sub aa()
Dim i, j, t, arr, maxcolsize, defaultfontsize, brr, n As Long
defaultfontsize = [a1].Font.Size
Application.ScreenUpdating = False
arr = Range("a1:b" & [a65536].End(xlUp).Row)
ReDim brr(1 To UBound(arr, 1), 1 To 2)
With [b:c]
.ClearContents
.Font.Size = defaultfontsize
.Font.Name = "GWIPA"
End With
For i = 1 To UBound(arr, 1)
t = Split(arr(i, 1), "Q")
arr(i, 1) = t(0) & "Q": arr(i, 2) = t(1)
Next
[b1].Resize(UBound(arr, 1), 1) = arr
[b:b].Columns.AutoFit: maxcolsize = [b:b].Width
For i = 1 To UBound(arr, 1)
[c:c].Font.Size = defaultfontsize
Cells(1, 3) = arr(i, 1): [c:c].Columns.AutoFit
If [c:c].Width < maxcolsize Then
For j = 1 To 1000
Cells(1, 3) = Space(1) & Cells(1, 3)
[c:c].Columns.AutoFit: t = [c1].Width
If t >= maxcolsize Then Exit For
Next
brr(i, 1) = j
If t > maxcolsize Then
For j = defaultfontsize To 1 Step -0.5
Cells(1, 3).Characters(1, 1).Font.Size = j
[c:c].Columns.AutoFit: t = [c:c].Width
If t <= maxcolsize Then
If n > 0 Then
brr(i, 2) = j + IIf(maxcolsize - t < n - maxcolsize, 0, 0.5)
Else
brr(i, 2) = j
End If
n = 0: Exit For
End If
n = t
Next
Else
brr(i, 2) = defaultfontsize
End If
Cells(1, 3).Font.Size = defaultfontsize
Else
brr(i, 1) = 0: brr(i, 2) = defaultfontsize
End If
Next
For i = 1 To UBound(arr, 1)
arr(i, 1) = Space(brr(i, 1)) & arr(i, 1) & arr(i, 2)
Next
[b1].Resize(UBound(arr, 1), 1) = arr
For i = 1 To UBound(arr, 1)
With Cells(i, 2)
.Characters(1, 1).Font.Size = brr(i, 2)
.Characters(InStr(Cells(i, 2), "Q"), 1).Font.Color = vbRed
End With
Next
[b:b].Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub aa()
Dim i, j, t, arr, maxcolsize, defaultfontsize, brr, n As Long
defaultfontsize = [a1].Font.Size
Application.ScreenUpdating = False
arr = Range("a1:b" & [a65536].End(xlUp).Row)
ReDim brr(1 To UBound(arr, 1), 1 To 2)
With [b:c]
.ClearContents
.Font.Size = defaultfontsize
.Font.Name = "GWIPA"
End With
For i = 1 To UBound(arr, 1)
t = Split(arr(i, 1), "Q")
arr(i, 1) = t(0) & "Q": arr(i, 2) = t(1)
Next
[b1].Resize(UBound(arr, 1), 1) = arr
[b:b].Columns.AutoFit: maxcolsize = [b:b].Width
For i = 1 To UBound(arr, 1)
[c:c].Font.Size = defaultfontsize
Cells(1, 3) = arr(i, 1): [c:c].Columns.AutoFit
If [c:c].Width < maxcolsize Then
For j = 1 To 1000
Cells(1, 3) = Space(1) & Cells(1, 3)
[c:c].Columns.AutoFit: t = [c1].Width
If t >= maxcolsize Then Exit For
Next
brr(i, 1) = j
If t > maxcolsize Then
For j = defaultfontsize To 1 Step -0.5
Cells(1, 3).Characters(1, 1).Font.Size = j
[c:c].Columns.AutoFit: t = [c:c].Width
If t <= maxcolsize Then
If n > 0 Then
brr(i, 2) = j + IIf(maxcolsize - t < n - maxcolsize, 0, 0.5)
Else
brr(i, 2) = j
End If
n = 0: Exit For
End If
n = t
Next
Else
brr(i, 2) = defaultfontsize
End If
Cells(1, 3).Font.Size = defaultfontsize
Else
brr(i, 1) = 0: brr(i, 2) = defaultfontsize
End If
Next
For i = 1 To UBound(arr, 1)
arr(i, 1) = Space(brr(i, 1)) & arr(i, 1) & arr(i, 2)
Next
[b1].Resize(UBound(arr, 1), 1) = arr
For i = 1 To UBound(arr, 1)
With Cells(i, 2)
.Characters(1, 1).Font.Size = brr(i, 2)
.Characters(InStr(Cells(i, 2), "Q"), 1).Font.Color = vbRed
End With
Next
[b:b].Columns.AutoFit
Application.ScreenUpdating = True
End Sub