VBA WORD How to split doc in X docs? - vba

I'd like to split a doc file with some Units in individual units, taking Level 1 Outlined as stop mark. Someone could help me with this? As you can see, I'm a total newbie here. Thanks a lot

Well, I did this. It's not exactly and auto-split process but it does the thing:
Sub CutSelect()
Dim ruta As String
Selection.Cut
ruta = ActiveDocument.Path
Dim doc As Document
x = x + 1
Set doc = Documents.Add
Selection.Paste
'-----You can add some other things to do here
doc.SaveAs ruta & "\" & "Tema " & Format(x, "0")
'-----So here
doc.Close True
End Sub
X is set as global var. You can also do some Sub to restart counting as you wish

Found this. It'll work for text-only documents.
Option Explicit
Sub SplitNotes(delim As String, strFilename As String)
Dim doc As Document
Dim arrNotes
Dim I As Long
Dim x As Long
Dim Response As Integer
Dim ruta As String
ruta = ActiveDocument.Path
'Vector con los delimitadores
arrNotes = Split(ActiveDocument.Range, delim)
Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
If Response = 7 Then Exit Sub
For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
x = x + 1
Set doc = Documents.Add
doc.Range = arrNotes(I)
doc.SaveAs ruta & "\" & strFilename & Format(x, "0")
doc.Close True
End If
Next I
End Sub
Sub test()
' delimiter & filename
SplitNotes "///", "Tema "
End Sub
But I'd need to do this with full content, tables, images, etc.
I'm working on this too:
Sub TESTSplitNotes(delim As String, strFilename As String)
Dim doc As Document
Dim arrNotes
Dim I As Long
Dim Response As Integer
Dim ruta As String
Dim p As Paragraph
ruta = ActiveDocument.Path
Dim c As Range
Set c = ActiveDocument.Content
With c.Find
.Text = delim & "(*)" & delim
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Replacement.Text = ""
End With
'.Select
c.Find.Execute
While c.Find.Found
Debug.Print c.Start
Debug.Print c.End
'COPY CONTENT
Set r = ActiveDocument.Range(Start:=ini, End:=c.End - 3)
r.Select
Debug.Print ActiveDocument.Range.End
Selection.Copy
x = x + 1
Set doc = Documents.Add
Selection.Paste
'PASTE CONTENT
doc.SaveAs ruta & "\" & strFilename & Format(x, "0")
doc.Close True
ini = c.End - 3
Wend
End Sub
This work the first time, But I don't know how the Search iterates between found elements. After it works the first time,, c.end doesn't increase, it still be at the first position (for example, 3106). Does someone know why??

Related

Extract the text from a Range to use as the name of a document

I have found a macro that searches for a Heading1 format and splits my Word document based on that tag.
I want to extract the text from the H1 tag and use that to name the document - I can Debug print the text but I cannot get it to convert to a string.
Im sure its really simple but I cannot get it to work.
Here is my Macro as it stands (kudos to the original author) - It currently asks for a new name for the docs and uses that, I want to replace the ans$ with a string in the naming function
``
Sub Hones()
Dim aDoc As Document
Dim bDoc As Document
Dim Rng As Range
Dim myRng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim Counter As Long
Dim Ans$
Dim Foundtext As String
Ans$ = InputBox("Enter Filename", "Incremental number added")
If Ans$ <> "" Then
Set aDoc = ActiveDocument
Set Rng1 = aDoc.Range
Set Rng2 = Rng1.Duplicate
Do
With Rng1.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With
If Rng1.Find.Found Then
Foundtext = Rng1.Find.Found
Debug.Print Foundtext
Counter = Counter + 1
Rng2.Start = Rng1.End + 1
With Rng2.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With
If Rng2.Find.Found Then
Rng2.Select
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -1
Set Rng = aDoc.Range(Rng1.Start, Rng2.End)
Set bDoc = Documents.Add
bDoc.Content.FormattedText = Rng
bDoc.SaveAs Counter & ". " & Ans$ & ".docx", 16
'bDoc.SaveAs Counter & ". " & Foundtext & ".docx", wdFormatDocumentDefault
bDoc.Close
Else
'This collects from the last Heading 1 to the end of the document.
If Rng2.End < aDoc.Range.End Then
Set bDoc = Documents.Add
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -2
Set Rng = aDoc.Range(Rng2.Start, aDoc.Range.End)
bDoc.Content.FormattedText = Rng
'bDoc.SaveAs Counter & ". " & Foundtext & ".docx", wdFormatDocumentDefault
bDoc.SaveAs Counter & ". " & Ans$ & ".docx", wdFormatDocumentDefault
bDoc.Close
End If
End If
End If
Loop Until Not Rng1.Find.Found
'This is closing End If from Ans$
End If
End Sub
I believe the string contained a return at the end of it which the SaveAs function did not like
I replaced this
Foundtext = Rng1.Find.Found
Debug.Print Foundtext
with this
ftext = CStr(Rng1.Text)
namelength = Len(ftext)
Foundtext = Left(ftext, namelength - 2)
to trim the end off

Searching for a string of text from the main body and footnotes and copying it and its following # characters into an excel document

I have a large number of documents which I need to pull out file name references from, spread out across large blocks of text and footnotes.
I currently have a word VBA code that I think should search for a string (for example "This_") and then the following # of characters, and then paste them into a waiting excel sheet. I am struggling to get it to search both the footnotes and the main body of text.
I've been using the code below, but my work at the moment is making it do something weird. It will find the string I am searching for, but then it will copy from the start of the document the number of times the string has been found -- not the string and its subsequent text.
Any help would be appreciated in modifying this, I believe the issue will be coming from the first half of the 'return data to array section.
Option Explicit
Option Base 1
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
If IsWindowsOS Then
Tgt = "C:\users\user\" & TgtFile ' Windows OS
Else
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
ActiveDocument.StoryRanges(wdFootnotesStory).Select
With Selection.Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.workbooks.Open(Tgt)
Set mySh = myWB.sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
Public Function IsWindowsOS() As Boolean
If Application.System.OperatingSystem Like "*Win*" Then
IsWindowsOS = True
Else
IsWindowsOS = False
End If
End Function
Your code is a little confused as there is an unholy mix of Selection and Range. It is good practice to avoid using Selection as it is very rarely necessary to select anything when working in VBA.
VBA also has compiler constants that can be used to detect, among other things, whether code is being run on a Mac. Not sure if the Mac constant still works reliably as I no longer have one to test on.
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
'This isn't necessary as there is a compiler constant that can be used to identify code is running on Mac
' If IsWindowsOS Then
' Tgt = "C:\users\user\" & TgtFile ' Windows OS
' Else
' Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
' End If
#If Mac Then
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
#Else
Tgt = "C:\users\user\" & TgtFile ' Windows OS
#End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
'not necessary to select the story range
'ActiveDocument.StoryRanges(wdFootnotesStory).Select
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
With oRng
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
End With
While .Find.Execute
'a match has been found and oRng redefined to the range of the match
i = i + 1
.MoveEnd wdCharacter, Lgth
arr(i) = .Text
.Collapse wdCollapseEnd
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
For example, the following code returns both the found text and its page reference:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrFnd As String, StrOut As String
StrFnd = InputBox("String to find")
j = InputBox("String Length to find")
k = j - Len(StrFnd)
For i = 1 To k
StrFnd = StrFnd & "^?"
Next
With ActiveDocument
For i = 1 To 2 ' 1 = wdMainTextStory, 2 = wdFootnotesStory, 3 = wdEndnotesStory, etc.
With .StoryRanges(i)
With .Find
.ClearFormatting
.Text = StrFnd
.Forward = True
.Format = True
.MatchWildcards = False
.Wrap = wdFindStop
.Replacement.Text = ""
End With
Do While .Find.Execute = True
StrOut = StrOut & vbCr & .Text & vbTab
Select Case .StoryType
Case wdMainTextStory
StrOut = StrOut & .Information(wdActiveEndAdjustedPageNumber)
Case wdFootnotesStory
StrOut = StrOut & .Duplicate.Footnotes(1).Reference.Information(wdActiveEndAdjustedPageNumber)
End Select
Loop
End With
Next
End With
MsgBox StrOut
Application.ScreenUpdating = True
End Sub
This is an example of how to search multiple section of your document. Note that I'm using a Collection to gather up the items, so you don't have to keep increasing an array.
Option Explicit
Option Base 1
Sub test()
Dim allFound As Collection
Set allFound = TextFoundReport("This_", 10)
Dim entry As Variant
For Each entry In allFound
Dim partType As Long
Dim text As String
Dim tokens() As String
tokens = Split(entry, "|")
'--- here is where you copy to an Excel sheet
Debug.Print "Part type: " & tokens(0) & " - '" & tokens(1) & "'"
Next entry
End Sub
Private Function TextFoundReport(ByVal text As String, _
ByVal numberOfCharacters As Long) As Collection
Dim whatWeFound As Collection
Set whatWeFound = New Collection
'--- create a list of the document parts to search
Dim docParts As Variant
docParts = Array(wdMainTextStory, wdFootnotesStory, wdEndnotesStory, wdCommentsStory)
Dim foundRng As Range
Dim docPart As Variant
For Each docPart In docParts
ActiveDocument.StoryRanges(docPart).Select
'--- find all occurences in this part and add it to the collection
' the Item in the collection is the story type and the found text
With Selection.Find
.ClearFormatting
.Forward = True
.text = text
.MatchCase = True
.Execute
Do While .found
Set foundRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Len(text), _
End:=Selection.Range.End + numberOfCharacters)
whatWeFound.Add CLng(docPart) & "|" & foundRng.text
foundRng.Start = foundRng.End
.Execute
Loop
End With
Next docPart
Set TextFoundReport = whatWeFound
End Function

VBA Page Break in MS Word

I am trying to combine individual MS Word docs into 1 MS Word doc. The below code works just fine to do that. The problem I am having is that I want to insert some code to create a page break after each document so that the next document starts on a new page. I believe something needs to be added in the Sumit routine.
I have tried every syntax that I can possibly find online. Nothing is working.
'Dim fso As New FileSystemObject
Dim NoOfFiles As Double
Dim counter As Integer
Dim r_counter As Integer
Dim s As String
Dim listfiles As Files
Dim newfile As Worksheet
Dim mainworkbook As Workbook
Dim FetchFileClicked
Dim Folderpath As Variant
Sub Sumit()
If FetchFileClicked = False Then
MsgBox "First click the 'Load Control File' button"
End
End If
Application.ScreenUpdating = False
strRandom = Replace(Replace(Replace(Now, ":", ""), "/", ""), " ", "")
MergeFileName = "Merger" & strRandom & ".doc"
MergeFolder = mainworkbook.Sheets("Main").Range("L10").Value
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.Visible = True
Set objSelection = objWord.Selection
objDoc.SaveAs (MergeFolder & MergeFileName)
For i = 1 To NoOfFiles
If Range("B" & i).Value = "Yes" Then
Set objTempWord = CreateObject("Word.Application")
Set tempDoc = objWord.Documents.Open(Folderpath & "\" & Range("A" & i).Value)
Set objTempSelection = objTempWord.Selection
tempDoc.Range.Select
tempDoc.Range.Copy
objSelection.TypeParagraph
objSelection.Paste
tempDoc.Close
End If
Next
objDoc.Save
Application.ScreenUpdating = True
mainworkbook.Sheets("Main").Activate
MsgBox "Completed...Merge File is saved at " & MergeFolder & MergeFileName
FetchFileClicked = False
End Sub
Sub fetchFiles()
Set mainworkbook = ActiveWorkbook
Range("A:A").Clear
Range("B:B").Clear
Folderpath = mainworkbook.Sheets("Main").Range("L8").Value
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 0
For Each fls In listfiles
counter = counter + 1
Range("A" & counter).Value = fls.Name
'Range("B" & counter).Value = "Yes"
Range("A" & counter).Borders.Value = 1
Range("B" & counter).Borders.Value = 1
With Range("B" & counter).Validation
.Delete
'replace "=A1:A6" with the range the data is in.
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="Yes,No"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Next
Call controlFile
MsgBox "Control File Loaded"
FetchFileClicked = True
End Sub
Sub controlFile()
Worksheets("Main").Range("b1:b6").Formula = "=iferror(VLOOKUP(A1,Table2,MATCH(""load"",Table2[#Headers],0),0),"""")&"""""
Application.Wait (Now + TimeValue("0:00:03"))
End Sub
I expect each of the individual documents that are added to the newly combined document to be added at the "start of a new page", NOT in the middle of an existing page, like it is today.

How to loop through files in a folder?

I'm attempting to Loop my Dir subroutine rather than copying the code all over again.
The code prompts a user for a search word.
A count is given in the document. Black (1 time), red (2 times), or bolded red (3+ times).
Images in the file are doubled in size. If there are no images a MsgBox says "no images in file".
To modify multiple documents with this program, I need to input a directory (Dir) and then loop through the files of the directory.
Sub austinolson()
Dim WordInput As String
Dim WordCount As Integer
Dim Range As word.Range
WordInput = InputBox("Search for a word")
'Everything below this code
Set Range = ActiveDocument.Content
WordCount = 0
With Range.Find
.ClearFormatting
.Format = False
.Forward = True
.MatchWholeWord = True
.Text = WordInput
.Wrap = wdFindStop
.Execute
Do While .Found
WordCount = WordCount + 1
Range.Collapse word.WdCollapseDirection.wdCollapseEnd
.Execute
Loop
End With
MsgBox ("The word: '" & "" & WordInput & "" & "' shows up " & WordCount & " times in the document")
ActiveDocument.Content.InsertParagraphAfter
Set Range = ActiveDocument.Content
Range.Collapse word.WdCollapseDirection.wdCollapseEnd
Range.Text = "Number occurrences: " & WordCount
If WordCount >= 3 Then
Range.Font.ColorIndex = wdRed
Range.Font.Bold = True
ElseIf WordCount >= 2 Then
Range.Font.ColorIndex = wdRed
Range.Font.Bold = False
Else
Range.Font.ColorIndex = wdBlack
Range.Font.Bold = False
End If
'Inline shape count below'
Dim h As Long
Dim w As Long
Dim rng As Range
Dim Ishape As InlineShape
Set rng = ActiveDocument.Content
If rng.InlineShapes.Count = 0 Then
MsgBox "No images to modify"
End If
For Each Ishape In ActiveDocument.InlineShapes
h = Ishape.Height
w = Ishape.Width
Ishape.Height = 2 * h
Ishape.Height = 2 * w
Next Ishape
'location input:
Dim Path As String
Dim currentFilename As String
currentFilename = ""
Path = ""
Do While (Path = "")
Path = InputBox("Location of documents e.g. C:\203\: ")
If (Path = "") Then
MsgBox ("No location entered, ending program")
Exit Sub
End If
Loop
'Everything above this code:
currentFilename = Dir(Path & "*.docx")
Do While (currentFilename <> "")
MsgBox (currentFilename)
If (currentFilename <> "") Then
Documents.Open (Path & currentFilename)
'
' Need to apply loop inbetween "Above and below code" HERE to the opened word documents.
'
ActiveDocument.Close (wdSaveChanges)
End If
currentFilename = Dir
Loop
End Sub
Here's what I mean - your main Sub gets user input and loops over the files, but the other tasks are split out into discrete Subs/Functions.
Compiled, but not tested, so you may need to fix some things...
Sub MainProgram()
Dim WordInput As String
Dim WordCount As Long, ImageCount As Long
Dim doc As Document
Dim Path As String
Dim currentFilename As String
currentFilename = ""
'get a path from the user
Path = Trim(InputBox("Location of documents e.g. 'C:\203\'"))
If Path = "" Then
MsgBox "No location entered, ending program"
Exit Sub
End If
If Right(Path, 1) <> "\" Then Path = Path & "\" 'ensure trailing slash
'get the search word
WordInput = Trim(InputBox("Search for a word"))
If Len(WordInput) = 0 Then Exit Sub 'maybe add a message here...
'start looping over the folder
currentFilename = Dir(Path & "*.docx")
Do While currentFilename <> ""
Set doc = Documents.Open(Path & currentFilename)
WordCount = CountTheWord(doc, WordInput) 'count the words
TagWordCount doc, WordInput, WordCount 'insert count to doc
ImageCount = ResizeInlineShapes(doc)
Debug.Print "'" & WordInput & "' shows up " & WordCount & " times in '" & doc.Name & "'"
Debug.Print "...and there were " & ImageCount & " images resized"
doc.Close wdSaveChanges
currentFilename = Dir
Loop
End Sub
Function CountTheWord(doc As Document, theWord As String) As Long
Dim WordCount As Long, rng As Range
Set rng = doc.Content
WordCount = 0
With rng.Find
.ClearFormatting
.Format = False
.Forward = True
.MatchWholeWord = True
.Text = theWord
.Wrap = wdFindStop
.Execute
Do While .Found
WordCount = WordCount + 1
rng.Collapse wdCollapseEnd
.Execute
Loop
End With
CountTheWord = WordCount
End Function
'append a word count to the end of the document
Sub TagWordCount(doc As Document, theWord As String, theCount As Long)
Dim rng As Range
doc.Content.InsertParagraphAfter
Set rng = doc.Content
rng.Collapse wdCollapseEnd
rng.Text = "Number occurrences for '" & theWord & "': " & theCount
rng.Font.Bold = (theCount >= 3)
rng.Font.ColorIndex = IIf(theCount >= 2, wdRed, wdBlack)
End Sub
Function ResizeInlineShapes(doc As Document) As Long
Dim rv As Long, Ishape As InlineShape
For Each Ishape In doc.InlineShapes
Ishape.Height = 2 * Ishape.Height
Ishape.Height = 2 * Ishape.Height
rv = rv + 1
Next Ishape
ResizeInlineShapes = rv '<< number of shapes resized
End Function

Do a simple calculation in word using VBA

I have many documents i need to edit, i have the Version of the document in the Header like "Version #" these documents have different versions, but are all a single integer value. These versions need to +1 so i need to get the number then just add 1 then save.
This is seeming pretty tricky and im not sure its possible. Any Help would be appreciated.
For example.
Old Document
"Version 2"
New Edit
"Version 3"
I can find and replace as i have learned from here.
Try:
Sub UpdateVersions()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String
Dim wdDoc As Document, wdSctn As Section, wdHdFt As HeaderFooter
strDocNm = ActiveDocument.FullName
strFolder = GetFolder: If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
For Each wdSctn In .Sections
With wdSctn
For Each wdHdFt In .Headers
With wdHdFt
If .LinkToPrevious = False Then
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Version [0-9]{1,}"
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found = True
.Text = "Version " & Split(.Text, " ")(1) + 1
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End If
End With
Next
End With
Next
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
This is a quick hack that may do what you wish.
First of all, make sure that you have the Scripting Runtime referenced in the Tools>Project>References menu. Secondly, I have understood that you have more than one document so this lot does everything in a folder.
I have just assumed, for this example, that the folder name is fixed. In Real Life you can modify the code to select the folder and then modify the code to go through sub-folders, but this is (a) a quick hack and (b) out of scope.
Public Sub IncreaseVersionNumbers()
' Make sure that the "Microsoft Scripting Runtime" library is enabled in the Tools>Projects>References
Dim sRootFolder As String
Dim oFSO As Scripting.FileSystemObject
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
sRootFolder = "C:\_Documents\VersionNumberTest\" ' You can grab this by a Folder Selection dialog box instead
Set oFSO = New Scripting.FileSystemObject
Set oFolder = oFSO.GetFolder(sRootFolder)
For Each oFile In oFolder.Files
If InStr(1, oFile.Name, ".doc", vbTextCompare) > 0 Then
ProcessDocument (sRootFolder & oFile.Name)
End If
Next oFile
End Sub
Private Sub ProcessDocument(sDocument As String)
Dim oDoc As Word.Document
Dim oSection As Word.Section
Dim oRange As Range
Dim sHeaderText As String
On Error Resume Next
Set oDoc = Documents.Open(sDocument)
For Each oSection In oDoc.Sections
Set oRange = oSection.Headers(wdHeaderFooterPrimary).Range
If Not oRange Is Nothing Then
ProcessHeaderRange oRange
End If
Set oRange = oSection.Headers(wdHeaderFooterFirstPage).Range
If Not oRange Is Nothing Then
ProcessHeaderRange oRange
End If
Set oRange = oSection.Headers(wdHeaderFooterEvenPages).Range
If Not oRange Is Nothing Then
ProcessHeaderRange oRange
End If
Next oSection
oDoc.Close wdSaveChanges
End Sub
Private Sub ProcessHeaderRange(oRange As Range)
Dim sText As String, sNewText As String
Dim nPosn As Long, nStart As Long, nEnd As Long
Dim sVersion As String, nVersion As Long
sText = oRange.Text & " "
nPosn = InStr(1, sText, "Version", vbTextCompare)
If nPosn > 0 Then
nStart = InStr(nPosn, sText, " ")
If nStart > 0 Then
nStart = nStart + 1
nEnd = InStr(nStart, sText, " ")
If nEnd > 0 Then
sVersion = Mid$(sText, nStart, nEnd - nStart)
nVersion = Val(sVersion)
nVersion = nVersion + 1
sNewText = Left$(sText, nStart - 1) & Trim$(Str$(nVersion)) & " " & Right$(sText, Len(sText) - nEnd)
sNewText = Left$(sNewText, Len(sNewText) - 1)
oRange.Text = sNewText
End If
End If
End If
End Sub
This is, as I say, a quick hack so it may not work perfectly but, as always, have backups!
This works by going through each of the three possible headers in each possible section of the document. And if it finds a header in a section then it does what you say.
And this version does go above single digit version numbers. But it's a quick hack, as I say and so needs extra work to make it really bullet-proof. Having said that, it's a reasonable start I would think.
Hope that this helps,
Malc