Word数値シーケンスを数値範囲に変換するマクロ（例：1,2,3から1-3）

Question

私は教授の本の著者と主題索引を作成しています。私はすでにMS Wordを使ってインデックスを作成しました。しかし今、私は実際の順序に変える必要がある各主語/著者の一連の連続番号を持っています。例えばので

：

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