word或WPS文字的vba代码分享

经验创意 · 24 次浏览
饺子吖 创建于 3天2小时前

1、word或wps文字中表格统一根据窗口自动调整

'实现代码一:
Sub 表格适应窗口()
    '
    '功能:一键更改文档中所有表格适应窗口
    '
    Dim objTable As Table
    Application.ScreenUpdating = False  '关闭屏幕刷新
    '遍历文档中的所有表格
    For Each objTable In ActiveDocument.Tables
        objTable.Select
       Selection.Tables(1).AutoFitBehavior (wdAutoFitWindow)
    Next objTable
    Application.ScreenUpdating = True      '开启屏幕刷新
    '提示用户操作完成
   MsgBox "已将全部表格更改为适应窗口。"
End Sub
 
 
'实现代码二:
Sub 表格适应窗口大小()
'
'功能:所有表格适应窗口大小
'
    Application.ScreenUpdating = False  '关闭屏幕刷新
For i= ActiveDocument.Tables.Count To 1 Step -1
ActiveDocument.Tables(i).AutoFitBehavior (2)
Next
    Application.ScreenUpdating = True      '开启屏幕刷新
    '提示用户操作完成
   MsgBox "已将全部表格更改为适应窗口。"
End Sub
 
2、word或wps文字中修改字数少于一定数量的表格单元格内容样式

Sub 短单元格样式()
    ' 
    '功能:修改当前文档中字数少于一定数量的表格单元格内容样式
    ' 
    Dim objDoc As Document
    Dim objTable As Table
    Dim objCell As Cell
    Dim cellText As String
    Dim cellContent As String
    Dim count As Integer
    Dim wordCount As Integer
    Dim styleName As String
    ' 设置引用
    Set objDoc = ActiveDocument
    count = 0

    ' 检查文档是否包含表格
    If objDoc.Tables.count = 0 Then
        MsgBox "文档中没有表格!", vbExclamation
        Exit Sub
    End If

   ' 用户输入与验证
     wordCount= InputBox("请输入字数边界(少于等于此数量则应用样式):", "短单元格改样式", "40")
   
   styleName = InputBox("请输入样式名称:", "短单元格样式", "")
   ' 判断样式是否存在
    If styleName = "" Then Exit Sub ' 用户取消输入
    If Not StyleExists(styleName) Then
        MsgBox "不存在 [" & styleName & "] 样式。"
        Exit Sub
    End If

    Application.ScreenUpdating = False  '关闭屏幕刷新
    ' 遍历所有表格
    For Each objTable In objDoc.Tables
        ' 遍历表格中的每个单元格
        For Each objCell In objTable.Range.Cells
            cellContent = objCell.Range.Text
            cellContent = Replace(cellContent, vbCr, "") ' 移除段落标记
            cellContent = Trim(cellContent) ' 去除首尾空格

            ' 检查字数是否超出
            If Len(cellContent) <= wordCount Then
                ' 更改样式
                 objCell.Range.Style = styleName
            End If
        Next objCell
    Next objTable

    
    ' 释放对象
    Set objDoc = Nothing
    Application.ScreenUpdating = True      '开启屏幕刷新
   MsgBox "更改完成"
End Sub

Function StyleExists(styleName As String) As Boolean
    On Error Resume Next
    StyleExists = Not ActiveDocument.Styles(styleName) Is Nothing
    On Error GoTo 0
End Function


回复内容
暂无回复
回复主贴