word macro split file on delimeter - vba

I have multiple large docx files (word 2010) which need to be split on basis of a delimiter ("///"). I tried using a macro given http://www.vbaexpress.com/forum/showthread.php?39733-Word-File-splitting-Macro-question
However it gives an error "This method or Property is not available since No Text is Selected" on the line colNotes(i).Copy (Sub SplitNotes(...)).
The macro is reproduced below:
Sub testFileSplit()
Call SplitNotes("///", "C:\Users\myPath\temp_DEL_008_000.docx")
End Sub
Sub SplitNotes(strDelim As String, strFilename As String)
Dim docNew As Document
Dim i As Long
Dim colNotes As Collection
Dim temp As Range
'get the collection of ranges
Set colNotes = fGetCollectionOfRanges(ActiveDocument, strDelim)
'see if the user wants to proceed
If MsgBox("This will split the document into " & _
colNotes.Count & _
" sections. Do you wish to proceed?", vbYesNo) = vbNo Then
Exit Sub
End If
'go through the collection of ranges
For i = 1 To colNotes.Count
'create a new document
Set docNew = Documents.Add
'copy our range
colNotes(i).Copy
'paste it in
docNew.Content.Paste
'save it
docNew.SaveAs fileName:=ThisDocument.path & "\" & strFilename & Format(i, "000"), FileFormat:=wdFormatDocument
docNew.Close
Next
End Sub
Function fGetCollectionOfRanges(oDoc As Document, strDelim As String) As Collection
Dim colReturn As Collection
Dim rngSearch As Range
Dim rngFound As Range
'initialize a new collection
Set colReturn = New Collection
'initialize our starting ranges
Set rngSearch = oDoc.Content
Set rngFound = rngSearch.Duplicate
'start our loop
Do
'search through
With rngSearch.Find
.Text = strDelim
.Execute
'if we found it... prepare to add to our collection
If .Found Then
'redefine our rngfound
rngFound.End = rngSearch.Start
'add it to our collection
colReturn.Add rngFound.Duplicate
'reset our search and found for the next
rngSearch.Collapse wdCollapseEnd
rngFound.Start = rngSearch.Start
rngSearch.End = oDoc.Content.End
Else
'if we didn't find, exit our loop
Exit Do
End If
End With
'shouldn't ever hit this... unless the delimter passed in is a VBCR
Loop Until rngSearch.Start >= ActiveDocument.Content.End
'and return our collection
Set fGetCollectionOfRanges = colReturn
End Function

For those who might be interested:
The code does work in 2010. The issue was a delimiter which was the first thing on the file...
Deleted it and it worked...

Related

Append Word docx files while keeping their format in VBA

I am creating a Word Macro that receives two arguments: a list of docx documents and the name of the new file. The goal is that the Macro inserts one document after the other, preserving their respective format, and saves as a new docx document.
Sub Merger(path As String, args () As Variant)
Dim vArg As Variant
Active Document.Select
Selection.ClearFormatting
For Each vArg In args
ActiveDocument.Content.Words.Last.Select
Selection.InsertFile:= _ vArg _,Range:="", _ConfirmConversions:= False, Link:=False, Attachment:= False )
Selection.InsertBreak Type:=wdPageBreak
Next vArg
ActiveDocument.SaveAs2 File Name=path
ActiveDocument.Close
Application.Quit
Note that I call the Macro from an empty docx file.
The problem is that neither the header nor the format of the orginal files are preserved in the new docx document.
The Word format is not modular. Instead, consider creating a Master Document, then filling it with subdocuments. Here's code to create a master document from a folder full of subdocuments:
Sub AssembleMasterDoc()
Dim SubDocFile$, FolderPath$, Template$
Dim Counter&
Dim oFolder As FileDialog
Dim oBookmark As Bookmark
Dim oTOC As TableOfContents
'Create a dynamic array variable, and then declare its initial size
Dim DirectoryListArray() As String
ReDim DirectoryListArray(1000)
Template$ = ActiveDocument.AttachedTemplate.Path & Application.PathSeparator & ActiveDocument.AttachedTemplate.Name
'Loop through all the files in the directory by using Dir$ function
Set oFolder = Application.FileDialog(msoFileDialogFolderPicker)
With oFolder
.AllowMultiSelect = False
If .Show <> 0 Then
FolderPath$ = .SelectedItems(1)
Else
GoTo EndSub
End If
End With
Application.ScreenUpdating = False
SubDocFile$ = Dir$(FolderPath$ & Application.PathSeparator & "*.*")
Do While SubDocFile$ <> ""
DirectoryListArray(Counter) = SubDocFile$
SubDocFile$ = Dir$
Counter& = Counter& + 1
Loop
'Reset the size of the array without losing its values by using Redim Preserve
ReDim Preserve DirectoryListArray(Counter& - 1)
WordBasic.SortArray DirectoryListArray()
ActiveWindow.ActivePane.View.Type = wdOutlineView
ActiveWindow.View = wdMasterView
Selection.EndKey Unit:=wdStory
For x = 0 To (Counter& - 1)
If IsNumeric(Left(DirectoryListArray(x), 1)) Then
FullName$ = FolderPath$ & Application.PathSeparator & DirectoryListArray(x)
Documents.Open FileName:=FullName$, ConfirmConversions:=False
With Documents(FullName$)
.AttachedTemplate = Template$
For Each oBookmark In Documents(FullName$).Bookmarks
oBookmark.Delete
Next oBookmark
.Close SaveChanges:=True
End With
Selection.Range.Subdocuments.AddFromFile Name:=FullName$, ConfirmConversions:=False
End If
Next x
For Each oTOC In ActiveDocument.TablesOfContents
oTOC.Update
Next oTOC
ActiveWindow.ActivePane.View.Type = wdPrintView
Application.ScreenUpdating = True
EndSub:
End Sub
This code is from a previous project, so you may not need all of it, like the update of multiple TOCs.
Don't attempt to maintain and edit Master Documents. The format is prone to corruption. Instead, assemble a master document for printing (or other use), then discard it.

VBA Code to change word footer in multiple files based on page number

I have a macro that runs to make a single page doc into a 5 page doc (NCR Duplicates) for all files in a folder.
I am using a set of nested IF fields in my footer, which changes the footer based on page number. The field looks like this
Text here {If{PAGE}="1""Original"{If{PAGE}="2""Copy 1"
{If{PAGE}="3""Copy 2"{If{PAGE}="4""Copy 3"{If{PAGE}="5""Copy 4"}}}}}
Other Text
I am trying to figure out how to add this footer to all the documents in a folder. It doesn't need to use field, if there is a way simply based on page number.
I have bashed my head against the wall, searched like crazy, and now come hat in hand.
The macro to make the duplicate copies is:
Sub Make5CopiesNCR()
vDirectory = BrowseForFolder
vFile = Dir(vDirectory & "\" & "*.*")
Do While vFile <> ""
Documents.Open FileName:=vDirectory & "\" & vFile
MakeCopies
vFile = Dir
Loop
End Sub
End Sub
Private Sub MakeCopies()
Dim i As Integer
Selection.WholeStory
Selection.Copy
For i = 1 To 6
Selection.PasteAndFormat wdFormatOriginalFormatting
Next
With ActiveDocument
.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=6 'Page number
.Bookmarks("\Page").Select
With Selection
.Delete
ActiveDocument.Close SaveChanges:=wdSaveChanges, OriginalFormat:=wdWordDocument
End With
End With
End Sub
The problem with using a mailmerge with your field construction is that it gets converted to the result. Try a field coded as:
{={PAGE}-1 \# "'Copy {={PAGE}-1}';;'Original'"}
Now, if you create the required 5 pages in your mailmerge main document, all the outputs will likewise be in multiples of 5 pages, with the correct page numbering.
Even if you use a mailmerge main document with only a single page, the outputs will have the field coding required to produce the correct numbering for however many more pages you want to add to the outputs.
As for replicating this in your existing files, simply create a document with the required footer content, then use a macro like:
Sub ReplicateFooter()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Rng As Range
Dim StrPth As String, StrNm As String, StrSrc As String
Set DocSrc = ActiveDocument
Set Rng = DocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range
StrPth = DocSrc.Path & "\": StrSrc = DocSrc.FullName
StrNm = Dir(StrPth & "*.doc", vbNormal)
While StrNm <> ""
If StrPth & StrNm <> StrSrc Then
Set DocTgt = Documents.Open(FileName:=StrPth & StrNm, AddToRecentFiles:=False, Visible:=False)
With DocTgt
With .Sections.First.Footers(wdHeaderFooterPrimary).Range
.FormattedText = Rng.FormattedText
.Characters.Last.Text = vbNullString
End With
.Close True
End With
End If
StrNm = Dir()
Wend
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

VBA Word macro goes to breakmode

I'm trying to open two documents from excel with vba and call a word macro from this particular excel file.
The macro is working fine in Word and I also get the documents to open and the word macro to start. However when there is a switch from one document to the other the word macro goes to break-mode (which does not happen when I run it from Word instead of Excel).
I use the following code from excel:
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\Word Dummy's\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y
In word I have a sub with the parameters defined between breakets and the following code:
worddoc2 = "H:\Word Dummy's\texts.docx"
Word.Application.Activate
Documents.Open worddoc2, ReadOnly:=True
ThisDocument.Activate
Set bmks = ThisDocument.Bookmarks
Can anyone tell me why it does not run from excel and how I can fix this?
Thanks in advance.
I finally found the answer myself after a lot of searching on Google.
I needed to add :
application.EnableEvents=false
To the excel macro.
That was all. Now it works.
My complete code is huge (the macro in excel also opens two other workbooks and runs a macro in them). This part of the code is working for now (so I left it out), but I just want to add the part that it opens a worddoc and adds specific texts in it depending on what client has been chosen in the excel userform. But to show you a better idea how my code looks like, this is in excel (where the client is defined by a userform in another module):
Sub open_models (client as string)
Application.DisplayStatusBar = True
‘determine datatypes
Dim m_integer As Integer
Dim m_ultimo As String
Dim m_primo As String
Dim y As String
Dim y_integer As Integer
Dim y_old As String
Dim y_last As String
Dim wordApp As Object
Dim worddoc As String
'Determine current month and year and previous
m_integer = Format(Now, "mm")
y_integer = Format(Now, "yyyy")
If m_integer <= 9 Then
m_ultimo = "0" & m_integer - 1
m_primo = "0" & m_integer - 2
Else
m_ultimo = m_integer - 1
m_primo = m_integer - 2
End If
If m_integer = 1 Then
y = y_integer - 1
Else
y = y_integer
End If
On Error Resume Next
'open word dummy
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y, varg4:= worddoc)
On Error GoTo 0
ThisWorkbook.Activate
'reset statusbar and close this workbook
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
ThisWorkbook.Close False
End Sub
 
And this is the code in word I am using:
Sub update_dummy(client As String, m_ultimo As String, y As String, worddoc as string)
Dim wordapp As Object
Dim rngStart As Range
Dim rngEnd As Range
Dim worddoc As String
Dim worddoc2 As String
Dim dekkingsgraad As String
Dim bmks As Bookmarks
Dim bmRange As Range
Dim rng As Range
Dim i As Boolean
On Error Resume Next
worddoc2 = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\dummytexts.docx"
'open other word
Documents.Open worddoc2, ReadOnly:=True
Documents(worddoc).Activate
Set bmks = Documents(worddoc).Bookmarks
'management summary
If client <> "PMT" Then
i = True
Set rngStart = Documents(worddoc2).Bookmarks("bn0_1_start").Range
Set rngEnd = Documents(worddoc2).Bookmarks("bn0_1_end").Range
End If
If i = True Then
Set rng = Documents(worddoc2).Range(rngStart.Start, rngEnd.End)
rng.Copy
Set bmRange = Documents(worddoc).Bookmarks("bmManagementsummary").Range
bmRange.PasteAndFormat (wdPasteDefault)
End If
i = False
On Error GoTo 0
End Sub
I have 20 more bookmarks that are defined but the code for them is all the same.
I have seen and solved this problem a few times before, the solution I found was odd.
Copy paste all your code into a text
editor, 1 for word, 1 for excel
Delete all the macros in word or excel or better yet, just create
new files.
Paste all the code into word/excel from your text editor.
I've definitely had this 3 or 4 times in Excel and Access. Especially if you previously had a breakpoint at that location.
It sounds stupid but try it and see if that works, this has saved me from insanity a few times.

Excel VBA Email Rows to a Single Recipient

I have a worksheet that tracks invoices and I am trying to generate an auto-emailer that if a cell in column 12 contains AUTOEMAIL it will combine all of the rows with a similar email address which I've generated using a TRIM function. It will pull all of the like rows (Email Addresses based on column 15) into a LotusNotes Email. Ron De Bruin has some fantastic examples on his site. I attempted to write a loop which attempts to loop through and copy all rows based on an email address. When I go to run, the code does nothing but no errors are presented. There are instances online of this done in Outlook, but they don't apply to LotusNotes as the issue is late vs early binding. I'm newer to VBA automation as well.
Sub Send_Data()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Const stSubject As String = "TEST"
Const stMsg As String = "TEST"
Const stPrompt As String = "Please select the range:"
lastrow = Range("N" & Rows.Count).End(xlUp).row
For Each Cell In Range("N8:N" & lastrow)
If WorksheetFunction.CountIf(Range("N8:N" & Cell.row), Cell) = 1 Then
If Cells(Cell.row, 11) = "AUTOEMAIL" Then
rnBody = "Hello" & vbNewLine & vbNewLine & _
ActiveCell.EntireRow.Select
On Error Resume Next
'The user canceled the operation.
If rnBody Is Nothing Then Exit Sub
On Error GoTo 0
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
rnBody.Copy
'Retrieve the data from then copied range.
Set Data = New DataObject
Data.GetFromClipboard
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
.Body = stMsg & " " & Data.GetText
.SaveMessageOnSend = True
End With
' SEND EMAIL
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
' REMOVE FROM MEMORY
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'SWITCH BACK TO EXCEL
AppActivate "Microsoft Excel"
'EMPTY COPY-PAST CLIPBOARD
Application.CutCopyMode = False
' DISPLAYS TO USER IF SUCCESSFUL
MsgBox "Complete!", vbInformation
End If
End If
Next Cell
End Sub
I set the email body range as a Prompt Box where the user could highlight the cells and then another prompt box in which it asked for the email that was created using a TRIM() function. I realized that the way the code was set-up would not allow for what I wanted to do. The new method works quite well
Treevar

Error in a Word VBA macro, trying to insert values into bookmarks

I'm trying to write a Word macro which inserts data from the Current User in Registry into predefined bookmarks in the document. I've got an ini-file which dictates what the names of each registry entry is, and that value is then imported into a loop in the Word Macro. This works fine (I think), but the Word macro needs to insert the data into the document as well. And this works fine if the bookmarks are there, but if they aren't, the macro seems to insert data anyway. I don't want that. I just want the macro to insert the data IF there's a bookmark coresponding to the name. I've made it so that each bookmark needs to be called ""Bookmark" & sBookMarkname".
And here's the code..
Sub MalData()
''
''// MalData Macro
''
Dim objShell
Dim strShell
Dim strDataArea
Dim Verdier() As String
Dim regPath
Dim regString
Dim Felter
Dim WScript
Dim sFileName As String
Dim iFileNum As Integer
Dim sBuf As String
sFileName = "C:\felter.ini"
If Len(Dir$(sFileName)) = 0 Then
MsgBox ("Can't find " & sFileName)
End If
''//Load values from ini-file which is later used to query the registry
Set objShell = CreateObject("Wscript.Shell")
With New Scripting.FileSystemObject
With .OpenTextFile(sFileName, ForReading)
If Not .AtEndOfStream Then regPath = .ReadLine
If Not .AtEndOfStream Then regString = .ReadLine
Do Until .AtEndOfStream
Felter = .ReadLine
On Error Resume Next
Dim sBookMarkName, sVerdi
sBookMarkNametemp = "Bookmark" & Felter
MsgBox (sBookMarkNametemp)
sVerdi = objShell.RegRead(regPath & "\" & Felter) ''"
sBookMarkName = ""
sBookMarkName = (sBookMarkNametemp)
If sVerdi <> Felter Then
Selection.GoTo What:=wdGoToBookmark, Name:=sBookMarkName
Selection.Delete Unit:=wdCharacter, Count:=0
Selection.InsertAfter sVerdi
ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:=sBookMarkName
End If
Loop
On Error GoTo 0
End With
End With
End Sub
Now, the error happens at about here:
sVerdi = objShell.RegRead(regPath & "\" & Felter) ''"
sBookMarkName = ""
sBookMarkName = (sBookMarkNametemp)
If sVerdi <> Felter Then
Even if the registry only contains three keys, the macro goes through every name gotten from the text file and inserts the last registry key multiple times.
Why don't you check if the bookmark exists before inserting the name?
If ActiveDocument.Bookmarks.Exists(sBookmarkName) Then
... insert using your code
End If