I am exporting an excel table into word using VBA. The word document has one bookmark. The code is such that first it writes the TYPE as the heading and then write all the description under that TYPE. I want the headings to be bold and formatted. I have the following code but it does not work. If anyone could suggest something.
If Dir(strPath & "\" & strFileName) <> "" Then
'Word Document open
On Error Resume Next
Set objWDApp = GetObject(, "Word.Application")
If objWDApp Is Nothing Then Set objWDApp = CreateObject("Word.Application")
With objWDApp
.Visible = True 'Or True, if Word is to be indicated
.Documents.Open (strPath & "\" & strFileName)
Set objRng = objWDApp.ActiveDocument.Bookmarks("Bookmark").Range
.Styles.Add ("Heading")
.Styles.Add ("Text")
With .Styles("Heading").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = True
End With
With .Styles("Text").Font
.Name = "Arial"
.Size = 10
.Bold = False
.Underline = False
End With
End With
On Error GoTo 0
i = Start_Cell
idx(1) = i
n = 2
Do ' Search for first empty cell in the table
i = i + 1
If i > Start_Cell + 1 And Cells(i, QB_Type).Value = Cells(i - 1, QB_Type) Then GoTo Loop1
idx(n) = i
n = n + 1
Loop1:
Loop Until IsEmpty(Cells(i + 1, QB_Type).Value)
idxEnd = i
idx(n) = 9999
i = Start_Cell
n = 1
Do
If i = idx(n) Then
strTMP = vbNewLine & vbNewLine & Cells(idx(n), QB_Type).Value & vbNewLine
With objWDApp
'.Selection.Font.Bold = True 'Type Bold (Doesnt Functions!?)
.Selection.Styles ("Heading") 'I tried this as well but not functioning...gives an error here that object does not support this property
WriteToWord objRng, strTMP 'Text written
End With
n = n + 1
End If
strTMP = vbNewLine & Cells(i, QB_Description).Value & vbNewLine
With objWDApp
' .Selection.Font.Bold = False 'Description Not bold (Not functioning!?)
.Selection.Styles("Text") 'This is also not functioning
WriteToWord objRng, strTMP 'Text written
End With
i = i + 1 'Arbeitspunktzähler erhöhen
Loop Until i > idxEnd
Public Sub WriteToWord(objRng, text)
With objRng
.InsertAfter text
End With
End Sub
Try .Selection.Style.Name = "Heading" from here
Edit 2
The following code works as expected. You will need to modify it to fit your needs. I successfully added and then bolded text to an existing word document.
Option Explicit
Public Sub Test()
' Add a reference to Microsoft Word x.0 Object Library for early binding and syntax support
Dim w As Word.Application
If (w Is Nothing) Then Set w = New Word.Application
Dim item As Word.Document, doc As Word.Document
' If the document is already open, just get a reference to it
For Each item In w.Documents
If (item.FullName = "C:\Path\To\Test.docx") Then
Set doc = item
Exit For
End If
Next
' Else, open the document
If (doc Is Nothing) Then Set doc = w.Documents.Open("C:\Path\To\Test.docx")
' Force change Word's default read-only/protected view
doc.ActiveWindow.View = wdNormalView
' Delete the preexisting style to avoid an error of duplicate entry next time this is run
' Could also check if the style exists by iterating through all styles. Whichever method works for you
doc.Styles.item("MyStyle").Delete
doc.Styles.Add "MyStyle"
With doc.Styles("MyStyle").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = wdUnderlineSingle
End With
' Do your logic to put text where you need it
doc.Range.InsertAfter "This is another Heading"
' Now find that same text you just added to the document, and bold it.
With doc.Content.Find
.Text = "This is another Heading"
.Execute
If (.Found) Then .Parent.Bold = True
End With
' Make sure to dispose of the objects. This can cause issues when the macro gets out mid way, causing a file lock on the document
doc.Close
Set doc = Nothing
w.Quit
Set w = Nothing
End Sub
By adding a reference to the object library, you can get intellisense support and compilation errors. It would help you determine earlier in development that Styles is not a valid property off the Word.Application object.
Related
My intention is to use a VBA code to extract the comments from a PowerPoint document and paste the information in a table in Word.
I started to build a code that works on Word and I tried to adapt in to work with PowerPoint. Unfortunately I run in some errors like Error 07 memory issue, while the code works perfectly to extract comments form a word document...
I am lost and do not know what to do...
Is there an expert who could help me verifying the code? I made notes in the code to make it easy to read.
PS: In PowerPoint VBA Editor, I did enabled the reference for Word.
Sub Tansfer_PPT_comments_in_WordDoc()
Dim n As Long
Dim nCount As Long
Dim ppt As Presentation
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim wdtable As Table
Set ppt = ActivePresentation
nCount = ActivePresentation.Comments.Count
'Open a Word document
On Error Resume Next
Set wdapp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdapp = CreateObject("Word.Application")
End If
On Error GoTo 0
'Create word page with landscape orientation
Set wddoc = Documents.Add
wddoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 5-column table
With wddoc
.Content = ""
Set wdtable = .Tables.Add _
(Range:=Selection.Range, _
Numrows:=nCount + 1, _
NumColumns:=5)
End With
'DOCUMENT FORMATTING
'Define Normal and Header style
With wddoc.Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With wddoc.Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Format table
With wdtable
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns(1).PreferredWidth = 2
.Columns(2).PreferredWidth = 20
.Columns(3).PreferredWidth = 40
.Columns(4).PreferredWidth = 8
.Columns(5).PreferredWidth = 40
.Rows(1).HeadingFormat = True
.Columns(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Rows(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Font.ColorIndex = wdDarkBlue
Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColor = wdColorAutomatic
Selection.Shading.BackgroundPatternColor = -603937025
End With
'Add table borders
With wdtable.Borders
.InsideLineStyle = Options.DefaultBorderLineStyle
.InsideLineWidth = Options.DefaultBorderLineWidth
.InsideColor = Options.DefaultBorderColor
.OutsideLineStyle = Options.DefaultBorderLineStyle
.OutsideLineWidth = Options.DefaultBorderLineWidth
.OutsideColor = Options.DefaultBorderColor
End With
'DOCUMENT CONTENT
'Define table headings names
With wdtable.Rows(1)
.Range.Font.Bold = True
.Cells(1).Range.Text = "Page"
.Cells(2).Range.Text = "Comment scope"
.Cells(3).Range.Text = "Comment text"
.Cells(4).Range.Text = "Author"
.Cells(5).Range.Text = "Parexel response"
End With
'Insert information from the comments in ppt into the wddoc table
For n = 1 To nCount
With wdtable.Rows(n + 1)
'Page number
.Cells(1).Range.Text = _
ppt.Comments(n).Scope.Information(wdActiveEndPageNumber)
'The text marked by the comment
.Cells(2).Range.Text = ppt.Comments(n).Scope
'The comment itself
.Cells(3).Range.Text = ppt.Comments(n).Range.Text
'The comment author
.Cells(4).Range.Text = ppt.Comments(n).Author
End With
Next n
ScreenUpdating = True
Application.ScreenRefresh
wddoc.Activate
Set ppt = Nothing
Set wddoc = Nothing
Set wdtable = Nothing
End Sub
Your code will fail at:
ActivePresentation.Comments.Count
since Comments are not a Presentation property. And, once you get over that hurdle, your code will fail at:
.Scope.Information(wdActiveEndPageNumber)
since PowerPoint Comments don't have a scope property and, even if they did, '.Information(wdActiveEndPageNumber)' refers to a Word constant, not a PowerPoint one.
You can't simply take VBA methods, properties, and constants that apply to one application and assume they apply to another in the same way. You need to develop your PowerPoint code using valid PowerPoint methods, properties, and constants.
For some code to get you started on the right tack, see: http://www.pptfaq.com/FAQ00900_Export_comments_to_a_text_file_-PowerPoint_2002_and_later-.htm
I have a Word document containing a table with two columns
column 1 contains numbers
column 2 contains text
Users introduce comments on the text in column 2 (see drawing).
I can create a table putting together all the comments with this code.
How do I access the number of the other column with reference to the texts commented?
The result so far is like this:
I need the number in the first column next to the text containing the comment.
I guess there is a method similar to:
oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
but accessing the table cell - and then I could refer to the same row and first column to grab the content of the first column?
Following is code that produces the table above. Be aware the code does not take into account that the comments are made on text belonging to table cells, Which is what I am looking for.
Sub ExtractCommentsToNewDocument()
'=========================
'Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com
'Revised October 2013 by Lene Fredborg: Date column added to extract
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim nCount As Long
Dim n As Long
Dim Title As String
Title = "Extract All Comments to New Document"
Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count
If nCount = 0 Then
MsgBox "The active document contains no comments.", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract all comments to a new document?", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If
Application.ScreenUpdating = False
'Create a new document for the comments, base on Normal.dot
Set oNewDoc = Documents.Add
'Set to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 4-column table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(range:=Selection.range, _
NumRows:=nCount + 1, _
NumColumns:=5)
End With
'Insert info in header - change date format as you wish
oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).range.Text = _
"Comments extracted from: " & oDoc.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With oNewDoc.Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With oNewDoc.Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Format the table appropriately
With oTable
.range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 5
.Columns(2).PreferredWidth = 23
.Columns(3).PreferredWidth = 42
.Columns(4).PreferredWidth = 18
.Columns(5).PreferredWidth = 12
.Rows(1).HeadingFormat = True
End With
'Insert table headings
With oTable.Rows(1)
.range.Font.Bold = True
.Cells(1).range.Text = "Page"
.Cells(2).range.Text = "Code"
.Cells(3).range.Text = "Text"
.Cells(4).range.Text = "Interview"
.Cells(5).range.Text = "Date"
End With
'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
With oTable.Rows(n + 1)
'Page number
.Cells(1).range.Text = _
oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
'The comment itself
.Cells(2).range.Text = oDoc.Comments(n).range.Text
'The text marked by the comment
.Cells(3).range.Text = oDoc.Comments(n).Scope
'The comment author
.Cells(4).range.Text = oDoc.Comments(n).Author
'The comment date in format dd-MMM-yyyy
.Cells(5).range.Text = Format(oDoc.Comments(n).Date, "dd-MMM-yyyy")
End With
Next n
Application.ScreenUpdating = True
Application.ScreenRefresh
oNewDoc.Activate
MsgBox nCount & " comments found. Finished creating comments document.", vbOKOnly, Title
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
End Sub
After:
.Cells(3).Range.Text = oDoc.Comments(n).Scope
Insert:
If oDoc.Comments(n).Scope.Information(wdWithInTable) = True Then
If oDoc.Comments(n).Scope.Cells(1).ColumnIndex > 1 Then
.Cells(3).Range.InsertBefore Split(oDoc.Comments(n).Scope.Rows(1).Cells(1).Range.Text, vbCr)(0) & vbTab
End If
End If
I have been working with code that I found HERE but I am having difficulty getting it to do one more task for me. I have added another column (3) to my excel document that has the "classification" of the acronym & definition and I want to add that to the newly created word doc in column 1, before the acronym. I have tried several different ways of moving the provided code around but it always results in an error. Any help is appreciated. I have included the working code below. Like I said, it works I just want it to do one more thing. Thank you!
Sub ExtractACRONYMSToNewDocument()
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim strDef As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim m As Long
m = 0
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Dim objExcel As Object
Dim objWbk As Object
Dim rngSearch As Object
Dim rngFound As Object
Dim targetCellValue As String
' message box title
Title = "Extract Acronyms to New Document"
' Set message box message
Msg = "This macro finds all Acronyms (consisting of 2 or more " & _
"uppercase letters, Numbers or '/') and their associated definitions. It " & _
"then extracts the words to a table at the current location you have selected" & vbCr & vbCr & _
"Warning - Please make sure you check the table manually after!" & vbCr & vbCr & _
"Do you want to continue?"
' Display message box
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
' Stop the screen from updating
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
' give the active document a variable
Set oDoc_Source = ActiveDocument
'Create a variable for excel and open the definition workbook
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("C:\Users\USERNAME\Documents\Test_Definitions.xlsx")
'objExcel.Visible = True
objWbk.Activate
'Create new document to temporarily store the acronyms
Set oDoc_Target = Documents.Add
' Use the target document
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=4)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Classification"
.Cell(1, 2).Range.Text = "Acronym"
.Cell(1, 3).Range.Text = "Definition"
.Cell(1, 4).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 15
.Columns(2).PreferredWidth = 25
.Columns(3).PreferredWidth = 55
.Columns(4).PreferredWidth = 5
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
' within the total range of the source document
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z][A-Z0-9/]{1" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(2, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 2).Range.Text = strAcronym
'Insert page number in column 4
.Cell(n + 1, 4).Range.Text = oRange.Information(wdActiveEndPageNumber)
' Find the definition from the Excel document
With objWbk.Sheets("Sheet1")
' Find the range of the cells with data in Excel doc
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
' Search in the found range for the
Set rngFound = rngSearch.Find(What:=strAcronym, After:=.Range("A1"), LookAt:=1)
' if nothing is found count the number of acronyms without definitions
If rngFound Is Nothing Then
m = m + 1
' Set the cell variable in the new table as blank
targetCellValue = ""
' If a definition is found enter it into the cell variable
Else
targetCellValue = .Cells(rngFound.Row, 2).Value
End If
End With
' enter the cell varibale into the definition cell
.Cell(n + 1, 3).Range.Text = targetCellValue
End With
' add one to the loop count
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 2", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
' update screen
Application.ScreenUpdating = True
'If no acronyms found set message saying so
If n = 1 Then
Msg = "No acronyms found."
' set the final messagebox message to show the number of acronyms found and those that did not have definitions
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document. Unable to find definitions for " & m & " acronyms."
End If
' Show the finished message box
On Error Resume Next
AppActivate Application.Caption
On Error GoTo 0
MsgBox Msg, vbOKOnly, Title
'Close Excel after
objWbk.Close Saved = True
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
Set objExcel = Nothing
Set objWbk = Nothing
End Sub
If anyone is looking for this solution, I was able to figure it out by duplicating the following lines. It then counts how many definitions and classifications it was unable to find and reports at the end.
' Find the definition from the Excel document
With objWbk.Sheets("Sheet1")
' Find the range of the cells with data in Excel doc
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
' Search in the found range for the
Set rngFound = rngSearch.Find(What:=strAcronym, After:=.Range("A1"), LookAt:=1)
' if nothing is found count the number of acronyms without definitions
If rngFound Is Nothing Then
m = m + 1
' Set the cell variable in the new table as blank
targetCellValue = ""
' If a definition is found enter it into the cell variable
Else
targetCellValue = .Cells(rngFound.Row, 2).Value
End If
End With
' enter the cell varibale into the definition cell
.Cell(n + 1, 3).Range.Text = targetCellValue
End With
I have VBA code that runs through a document and identifies acronyms using wildcards and places them in a separate word document. Some of my writers don't always follow the proper style guides for acronyms so I'm running four different scripts to find all the possible acronyms. It's time consuming and I end up with multiple documents. Is there a method to run multiple searches from one script and have all the results placed in the separate document. Truth in Advertising: I found this script on the 'net, but I've been playing with it to attempt to make it do some other features. Adding current script:
Sub ExtractVariousValuesACRONYMSToNewDocument()
'The macro creates a new document,
'finds all words consisting of 2 or more uppercase letters
'in the active document and inserts the words
'in column 1 of a 3-column table in the new document
'Each acronym is added only once
'Use column 2 for definitions
'Page number of first occurrence is added by the macro in column 3
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract Acronyms to New Document"
'Show msg - stop if user does not click Yes
Msg = "This macro finds all words consisting of 2 or more " & _
"uppercase letters and extracts the words to a table " & _
"in a new document where you can add definitions." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
.Cell(1, 3).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 2 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z]{2" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close savechanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub
The best solution would be one searching pattern for all cases. Word hasn't full regular expressions, it is not always possible. Write all four patterns, maybe there is a way for join them into one super-pattern.
The second possibility is running multiple times the same algorithm in one macro, something like this:
Sub Example()
Dim patterns As String
Dim pts() As String
'list of patterns for each run delimited by a delimiter - comma in this example
patterns = "first pattern, second pattern, and so on"
pts = Split(patterns, ",") 'the second parameter is a delimiter
Dim i As Integer
For i = 0 To UBound(pts)
'do your subroutine for each searching pattern
Next i
'save document with result
End Sub
For better answer give us more details, please.
I have a VBA subroutine which performs miscellaneous formatting to Word documents. It relies on the Selection object (Selection.WholeStory) to apply the formatting.
This subroutine is called from VBA Outlook with a Word.Application object.
The problem that arises is: when another instance of Word is open when the macro is called, the Selection Object refers to the Word document already open, not the handler created in my macro.
VBA does not seem to qualify the selection objct, so when you write Selection.PageSetup (ie) and start applying changes, it is applied to the Document already open in Word, not the document you are handling from VBA.
I've looked around for the answer on MSDN and here, but to no luck. If anyone knows how to qualify this object, let me know. Thanks.
Basically,
create word handler
open attachment in word
Selection.WholeStory
With Selection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
/* etc */
End with
Since "Selection" cannot be qualified, all these changes get made to whatever is already open.
if numTextFiles >= 1 then
for each textFile in textFileNames
'Open text file in word
Set doc = WordApp.Documents.Open(outReportFullDir & "\" & textFile)
'Set the output name of word doc (change .txt to .docx)
reportWordName = left(textFile, len(textFile) - 4)
reportWordName = reportWordName & ".docx"
'Check if out word document already exists
preventOverwrite(outReportFullDir & "\" & reportWordName)
'Format Reports
formatReport()
'etc
_
Private Sub formatReport()
documents(docToFormat).select
Selection.WholeStory
'Added by Ryan to make single-spaced
WordBasic.OpenOrCloseParaBelow
WordBasic.OpenOrCloseParaBelow
Selection.Font.Name = "Courier New"
Selection.Font.Size = 8
With Selection.PageSetup
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End Sub
There is probably confusion between Word's selection object and Outlook's selection object.
Use
WordApp.Selection
i.e.
WordApp.Selection.WholeStory
WordApp.Selection.Font.Name = "Courier New"
etc.
(or e.g.
Dim sel as Word.Selection
Set sel = WordApp.Selection
sel.WholeStory
sel.Font.Name = "Courier New"
Set sel = Nothing
So that if WordApp is not in scope, you should be able to use something like
Set sel = doc.Application.Selection
)
Finally, if you can get away with using Word Range instead, I would do so (e.g. doc.Range or Doc.Content) and avoid the whole Selection thing.
Have you tried something like this? It looks like you're getting a proper reference to the correct document at one stage in the game.
if numTextFiles >= 1 then
for each textFile in textFileNames
'Open text file in word
Set doc = WordApp.Documents.Open(outReportFullDir & "\" & textFile)
'Set the output name of word doc (change .txt to .docx)
reportWordName = left(textFile, len(textFile) - 4)
reportWordName = reportWordName & ".docx"
'Check if out word document already exists
preventOverwrite(outReportFullDir & "\" & reportWordName)
'Format Reports
Call formatReport(doc)
'etc
Private Sub formatReport(ByRef doc)
documents(doc).select
Selection.WholeStory
'Added by Ryan to make single-spaced
WordBasic.OpenOrCloseParaBelow
WordBasic.OpenOrCloseParaBelow
Selection.Font.Name = "Courier New"
Selection.Font.Size = 8
With Selection.PageSetup
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End Sub