关于exccel不能同时自动换行和缩小字体填充的一点VBA编程小尝试
本帖最后由 Tingamm 于 2024-11-24 23:32 编辑VBA代码如下：
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更新
在网上抄了一段按关键字多选工作表的代码，加上自己摸索之后更新新的代码如下：
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
最后附模块文件。
比较实用，支持支持 很实用的vba，在我的模块里加上这段 本人文盲：
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 试试看看好不好用 感谢分享 插入代码可以参考这个帖子
【公告】发帖代码插入以及添加链接教程（有福利）
https://www.52pojie.cn/thread-713042-1-1.html
(出处: 吾爱破解论坛)
Smallhorse 发表于 2024-11-24 10:37
本人文盲：
Sub 字体调整()
' 将活动单元格的字体大小设置为10
感谢感谢 苏紫方璇 发表于 2024-11-24 18:51
插入代码可以参考这个帖子
【公告】发帖代码插入以及添加链接教程（有福利）
https://www.52pojie.cn/thr ...
感谢感谢 VBA很少见，支持一下
页:
[1]
2