用于将数字序列转换为数字范围的字宏（例如：1、2、3 转换为 1-3）

Question

我正在为一本教授的书制作作者和主题索引。我已经使用 MS Word 创建了索引。但是现在我有一系列连续的数字 subject/author 需要变成一个实际的序列。

例如：

Agency (human and divine), 113, 114, 115, 339

需要成为

Agency (human and divine), 113–115, 339

我目前使用的 VBA 代码是 code found here 的修改版。原始代码的问题在于它漏掉了像 98–99 这样的双峰。相反，作者将下面修改后的代码发给我。这个修改后的代码的问题是，当它到达我的索引的末尾时，它一直在继续......它无法停止，所以 Word 最终冻结，然后我需要强行关闭它。

所以，我的问题是：是否可以编辑以下代码，使其在到达文档末尾时停止？如果是这样，如何？谢谢！

Sub RemoveSurplus()
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=1
   On Error GoTo SubEnd   'remove after debug
Do While Errornumber = 0
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    R1 = Selection
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    R2 = Selection
    If (R1 = "-" And R2 = "-") Then
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
        Selection.Delete Unit:=wdCharacter, Count:=1
    End If
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=False

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "[0-9]@, [0-9]@"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    N1 = Selection + 1
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    N2 = Selection + 1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    If (N2 = N1 + 1) Then
        Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
        Selection.TypeText Text:="-"
    Else: Selection.MoveRight Unit:=wdWord, Count:=1
    End If
 Loop
SubEnd:
End Sub

Answer 1

对于那些感兴趣的人，由于 Vipul Gajjar 的一些帮助，以下代码将完成这项工作。

Sub RemoveSurplus()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = falsee
    Application.StatusBar = True

    Dim totChar As Long

    KillEndBlanks

    totChar = ActiveDocument.Content.End - 13

    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=1
   On Error GoTo SubEnd   'remove after debug
Do While Errornumber = 0
    Application.StatusBar = "Please Wait: Line#[" & Selection.End & "] out of Lines#[" & ActiveDocument.Content.End & "] is in progress....!!!!"
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    R1 = Selection
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    R2 = Selection
    If (R1 = "-" And R2 = "-") Then
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
        Selection.Delete Unit:=wdCharacter, Count:=1
    End If
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=False

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "[0-9]@, [0-9]@"
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    N1 = Selection + 1
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    N2 = Selection + 1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    If (N2 = N1 + 1) Then
        Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
        Selection.TypeText Text:="-"
    Else: Selection.MoveRight Unit:=wdWord, Count:=1
    End If

    If Selection.End = endV And count1 < 100 Then
        endV = Selection.End
        count1 = count1 + 1
    ElseIf endV = Selection.End And count1 >= 100 Then
        GoTo SubEnd
    Else
        count1 = 0
        endV = Selection.End
    End If
 Loop
SubEnd:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
End Sub

Sub KillEndBlanks()
'
' KillEndBlanks Macro
'
    ' Go to the end of the file
    Selection.EndKey Unit:=wdStory
    ' Select the last character
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    ' As long as the last character is a carriage return [CHR(13)]...
    While Selection.Text = vbCr
        ' ... Delete the character, and select the new last character
        Selection.Delete Unit:=wdCharacter, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Wend
    ' Go to the end of the file again to not leave a character selected
    Selection.EndKey Unit:=wdStory
    While Selection.Text = Chr(13) Or Selection.Text = Chr(32)
        ' ... Delete the character, and select the new last character
        Selection.Delete Unit:=wdCharacter, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Wend
    Selection.Range.Text = Trim(Selection.Range.Text)
    Selection.HomeKey Unit:=wdStory
End Sub

用于将数字序列转换为数字范围的字宏（例如：1、2、3 转换为 1-3）

Word Macro for turning a number sequence into a number range (example: 1, 2, 3 into 1-3)

vba

ms-word

ms-office