如何用vba代码在文末统计字数？

zzpsx

附件.zip (15.16 KB, 下载次数: 3)

2024-3-22 16:25 上传

点击文件名下载附件

过客fppt

    Dim 文档字数0, 文档字数1 As Long
    Dim 总页数0, 总页数1 As Integer

    '文档所有文档字数和页面统计
    文档字数0 = ActiveDocument.ComputeStatistics(wdStatisticWords)
    总页数0 = ActiveDocument.ComputeStatistics(wdStatisticPages)

excel玉米

插入域法： 按快捷键Ctrl+F9，在灰块中输入numwords，再按F9，出现的数字就是这篇文章的总字数，并且这个数字是变化的（选中全文后按F9键就更新），这对于将文章字数作为文章一部分的应用是比较有用的，它可使结果动态更新、不用每次修改文章后再去修改字数。

413191246se

* 楼主，请注意：请复制代码到新建空白文档后，全选，剪切，再粘贴到 VBE 中。
* 首次使用请按 Alt + F8 找到本宏，运行之（在第一位）；下次再用直接按 F3 键即可。

1. Sub a0_DocWords()
   
2.     KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="a0_DocWords"
   
3.     ActiveDocument.Content.InsertAfter Text:=vbCr & "（本文一共" & ActiveDocument.ComputeStatistics(wdStatisticWords) & "个字）"
   
4.     ActiveDocument.Paragraphs.Last.Range.ParagraphFormat.Alignment = wdAlignParagraphRight
   
5. End Sub

复制代码

zzpsx

谢谢各位高手，我在你们的代码基础上进行了修改，结果如下：

Sub 统计word字数页数()
    Dim 文档字数 As Long
    Dim 总页数 As Integer
    ' 检查是否至少有一个文档打开
    If ActiveDocument Is Nothing Then
        MsgBox "没有打开的文档。", vbExclamation, "错误"
        Exit Sub
    End If
    ' 获取当前文档的字数和页数统计
    文档字数 = ActiveDocument.ComputeStatistics(wdStatisticWords)
    总页数 = ActiveDocument.ComputeStatistics(wdStatisticPages)
    ' 在文档末尾插入统计信息
    With ActiveDocument.content
        .InsertAfter "" & vbNewLine & _
                     "本文字数: " & 文档字数 & ", 总页数: " & 总页数
    End With
    ' 选择插入的文本，以便用户可以看到
    Selection.Range.SetRange ActiveDocument.content.End - 1, ActiveDocument.content.End
    ' 显示消息框确认统计信息已插入
End Sub


我希望的结果是这样，也就是括号内加红，如何修改代码：

过客fppt

Sub 你的代码()
.......你的代码的最后加

    Call 批量设置字体1("本文字数*页数：[0-3]{1,}", "仿宋", 3, True)
  
End Sub

Function 批量设置字体1(原文字, 字体为, 颜色为, 通配符, Optional ByVal 加粗 As Boolean = False)
    Dim rng As Range
    Set rng = IIf(Len(Selection.Range.text) <= 1, ActiveDocument.Content, Selection.Range)
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = 原文字
        .Forward = True
        .MatchWildcards = 通配符 '通配符开关
        With .Replacement
            .Font.Name = 字体为
            .Font.Name = "Times New Roman"
            .Font.ColorIndex = 颜色为 'wdDarkRed
            .Font.Bold = 加粗
        End With
    End With
    rng.Find.Execute Replace:=wdReplaceAll
    批量设置字体1 = rng.Find.Found
    Set rng = Nothing
End Function

zzpsx

谢谢各位，我自己也又写了一个：
Sub CountWordsAndPages()
    Dim wdDoc As Document
    Dim wdSelection As Selection
    Dim strText As String
    Dim intWords As Integer
    Dim intPages As Integer
   
    ' 获取当前文档对象
    Set wdDoc = ActiveDocument
    ' 获取当前选定内容对象
    Set wdSelection = wdDoc.ActiveWindow.Selection
   
    ' 获取文档的字数
    intWords = wdDoc.ComputeStatistics(wdStatisticWords)
    ' 获取文档的页数
    intPages = wdDoc.BuiltInDocumentProperties(wdPropertyPages)
   
    ' 构造统计结果字符串
    strText = "(本文档共" & intWords & "字，共" & intPages & "页)"
   
    ' 将光标移动到文档末尾
    wdSelection.EndKey Unit:=wdStory
    ' 插入换行符
    wdSelection.InsertBreak Type:=wdLineBreak
   
    ' 插入统计结果字符串
    wdSelection.Text = strText
    ' 设置字体颜色为红色
    wdSelection.Font.Color = wdColorRed
   
    ' 清理对象
    Set wdSelection = Nothing
    Set wdDoc = Nothing
End Sub

常扬帆

过客fppt 发表于 2024-3-23 22:44
Sub 你的代码()
.......你的代码的最后加

您这个思路好！下面的附件中，有各种字体，能不能把“整行全是仿宋体字的行”提出来另外存放？谢谢！

batmanbbs