Processing
 

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

08/09/2016 19:38#1

Peter G.

Member

Joined at: 10 months ago

Post: 3

Thank: 0

Thanked: 0

I am producing an author and subject index for a professor's book. I have already created the index using MS Word. But now I have a series of consecutive numbers for each subject/author that needs to be turned into an actual sequence.

So for example:

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

needs to become

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

The VBA code I'm currently using is a modification of code found here. The problem with that original code is that it missed doublets like 98–99. Instead, the author sent me the revised code below. The problem with this revised code is that, when it gets to the end of my index, it just keeps going and going and... It can't stop and so Word ends up freezing and then I need to force close it.

So, my question: can the following code be edited so that it stops when it hits the end of the document? If so, how? Thanks!

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 
20/09/2016 14:11Top#2

Peter G.

Member

Joined at: 10 months ago

Post: 3

Thank: 0

Thanked: 0

For those interested, the following code will do the job thanks to some help from 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 
Similar articles

VBA regex matching over two lines

4 months ago - Reply: 1 - Views: 44

Table output to Word-2011 from Rstudio using knit

4 months ago - Reply: 0 - Views: 32

Write a Collection of paragraphs into a new document

4 months ago - Reply: 1 - Views: 70

how to write paragraphs without show to document

4 months ago - Reply: 1 - Views: 66

numericals in word macro

4 months ago - Reply: 1 - Views: 45

Can not find proofing tools

4 months ago - Reply: 0 - Views: 1

Possible values for <w:outlineLvl> in Word OOXML

4 months ago - Reply: 1 - Views: 7

C# restrict editing partial word paragraph

5 months ago - Reply: 2 - Views: 142

Macro translation Please (possible virus)

4 months ago - Reply: 1 - Views: 34

Doc/Docx Fastest Reading Method for Searching

4 months ago - Reply: 0 - Views: 1

Save embedded file / content from word

4 months ago - Reply: 0 - Views: 5

Counting words in Word document, including footnores

4 months ago - Reply: 1 - Views: 22

c# access extract word ole object

4 months ago - Reply: 1 - Views: 19

Using word wildcards to find unaccepted changes

4 months ago - Reply: 1 - Views: 45

vé máy bay vé máy bay giá rẻ ve may bay ve may bay gia re vé máy bay vé máy bay giá rẻ ve may bay ve may bay gia re vé máy bay vé máy bay giá rẻ ve may bay ve may bay gia re vé máy bay vé máy bay giá rẻ ve may bay ve may bay gia re vé máy bay vé máy bay giá rẻ ve may bay ve may bay gia re vé máy bay vé máy bay giá rẻ ve may bay ve may bay gia re vé máy bay vé máy bay giá rẻ ve may bay ve may bay gia re