关于exccel不能同时自动换行和缩小字体填充的一点VBA编程小尝试

Tingamm

VBA代码如下：

[Visual Basic] 纯文本查看 复制代码

Sub 字体调整()
ActiveCell.Font.Size = 10
ActiveCell.WrapText = False
ActiveCell.ShrinkToFit = False
For i = 10 To 1 Step -0.5
    If Len(ActiveCell) <= Fix(ActiveCell.MergeArea.Width / i) * Fix(ActiveCell.MergeArea.Height / (i + 2)) Then
        ActiveCell.WrapText = True
        ActiveCell.Font.Size = i
        Exit For
    Else
        ActiveCell.ShrinkToFit = True
    End If
Next

End Sub

2024.11.24更新
在网上抄了一段按关键字多选工作表的代码，加上自己摸索之后更新新的代码如下：

[Visual Basic] 纯文本查看 复制代码

Dim maxSize As Long, minSize As Long
Dim keyWord As String

Sub 自动调整表格()
    
inputSize:
    
Call 输入字号

inputKey:

Call 输入关键字

Dim sameMban As Integer
sameMban = MsgBox("本次所调整含有该关键字的表格模板及数据格式是否一致？", vbYesNo, "提示")
If sameMban = vbYes Then Call 批量调整
If sameMban = vbNo Then Call 逐个调整

Dim continueTzheng As Integer
continueTzheng = MsgBox("是否继续调整？", vbYesNo, "提示")
If continueTzheng = vbYes Then
    Dim sameSize As Integer
    sameSize = MsgBox("是否以相同字号调整？", vbYesNo, "提示")
    If sameSize = vbYes Then GoTo inputKey
    If sameSize = vbNo Then GoTo inputSize
End If

If continueTzheng = vbNo Then End
    
End Sub

Sub 输入字号()

maxSize = Application.InputBox("设置最大字号（默认字号）", "设置字号", "10")
If maxSize = vbnot Then End

minSize = Application.InputBox("设置最小字号", "设置字号", "1")
If minSize = vbnot Then End

End Sub

Sub 输入关键字()

keyWord = Application.InputBox("请输入表名关键字", "输入关键字", "组1")
If keyWord = "False" Then End

End Sub

Sub 批量调整()

Dim bFlag As Boolean
Dim oSht As Worksheet
bFlag = True
For Each oSht In Sheets
    If InStr(oSht.Name, keyWord) Then
        If bFlag Then
            oSht.Select
            bFlag = False
        Else
            oSht.Select Replace:=False
        End If
    End If
Next

Call 遍历选定区域调整文本
Call 返回目录

End Sub

Sub 逐个调整()

Dim shtName As Worksheet, getName As String
For Each shtName In Worksheets()
    shtName.Activate
    getName = ActiveSheet.Name
    If InStr(getName, keyWord) Then
        ActiveSheet.Select
        Call 遍历选定区域调整文本
    End If
Next

Call 返回目录
End Sub

Sub 遍历选定区域调整文本()

On Error GoTo error

Dim arrAddress(), rngSelect
Set rngSelect = Application.InputBox("选定调整区域", Type:=8)

Dim rng As Range
For Each rng In Range(rngSelect.Address(0, 0))
    rng.Select
    Call 调整文本
Next

GoTo continue

error:

If rngSelect = 0 Then
    Call 返回目录
    End
End If

continue:

End Sub

Sub 调整文本()

ActiveCell.Font.Size = maxSize
ActiveCell.WrapText = False
ActiveCell.ShrinkToFit = False
ActiveCell.Interior.ColorIndex = 0

For i = maxSize To minSize Step -0.5
    Dim textLen As Long
    textLen = LenB(StrConv(ActiveCell, vbFromUnicode))
    
    Dim estimatedCapacity As Long, maxCapacity As Long
    estimatedCapacity = (Fix(ActiveCell.MergeArea.Width / (i + 0.07)) * Fix(ActiveCell.MergeArea.Height / (i + 2.05))) * 1.95
    maxCapacity = (Fix(ActiveCell.MergeArea.Width / (minSize + 0.07)) * Fix(ActiveCell.MergeArea.Height / (minSize + 2.05))) * 1.95
    
    If textLen <= estimatedCapacity Then
        ActiveCell.WrapText = True
        ActiveCell.Font.Size = i
        Exit For
    Else
        If textLen > maxCapacity Then
         MsgBox "字符过多！已将单元格背景颜色设置为黑色！", , "提示"
         ActiveCell.Interior.Color = RGB(0, 0, 0)
         Exit For
        End If
    End If
Next

End Sub

最后附模块文件。

50lovelace

比较实用，支持  支持

tnancy2kk

感谢，这个感觉有用啊，辛苦了，感谢

jori

很实用的vba，在我的模块里加上这段

Smallhorse

本人文盲：
Sub 字体调整()
    ' 将活动单元格的字体大小设置为10
    ActiveCell.Font.Size = 10
    ' 取消活动单元格的自动换行功能
    ActiveCell.WrapText = False
    ' 取消活动单元格的缩小字体填充功能
    ActiveCell.ShrinkToFit = False

    ' 开始一个循环，从10以步长 -0.5递减到1
    For i = 10 To 1 Step -0.5
        ' 获取活动单元格内文本的长度（这里指字符个数）
        Dim textLength As Long
        textLength = Len(ActiveCell)

        ' 计算基于当前字号以及单元格合并区域（如果存在合并区域）的宽度和高度所得到的一个可容纳文本长度的估计值
        ' 先分别计算宽度和高度方向上可容纳的字符数，然后相乘得到总的可容纳字符数估计值
        ' 使用Fix函数取整，去掉小数部分
        Dim estimatedCapacity As Long
        estimatedCapacity = Fix(ActiveCell.MergeArea.Width / i) * Fix(ActiveCell.MergeArea.Height / (i + 2))

        ' 如果活动单元格内文本的长度小于等于上述计算得到的可容纳文本长度的估计值
        If textLength <= estimatedCapacity Then
            ' 将活动单元格的自动换行功能设置为True，开启自动换行
            ActiveCell.WrapText = True
            ' 将活动单元格的字体大小设置为当前的循环变量i的值
            ActiveCell.Font.Size = i
            ' 找到合适的字号和显示方式后，退出循环
            Exit For
        Else
            ' 如果活动单元格内文本的长度大于上述计算得到的可容纳文本长度的估计值
            ' 将活动单元格的缩小字体填充功能设置为True，开启缩小字体填充
            ActiveCell.ShrinkToFit = True
        End If
    Next

End Sub

qvbfvtuu

试试看看好不好用

woaipj123

感谢分享

苏紫方璇

插入代码可以参考这个帖子
【公告】发帖代码插入以及添加链接教程（有福利）
https://www.52pojie.cn/thread-713042-1-1.html
(出处: 吾爱破解论坛)

Tingamm

Smallhorse 发表于 2024-11-24 10:37
本人文盲：
Sub 字体调整()
    ' 将活动单元格的字体大小设置为10

感谢感谢

Tingamm

苏紫方璇 发表于 2024-11-24 18:51
插入代码可以参考这个帖子
【公告】发帖代码插入以及添加链接教程（有福利）
https://www.52pojie.cn/thr ...

感谢感谢