Populate word document from excel without deleting bookmarks - vba

I am trying to populate a Word document based on data from Excel. Due to number of specific work requirements, I need to retain the bookmarks in Word. I have used these sites as resources.
Replace Text in Bookmark in Word without Deleting Bookmark
http://wordmvp.com/FAQs/MacrosVBA/InsertingTextAtBookmark.htm
http://www.wiseowl.co.uk/blog/s199/word-bookmarks.htm
I am getting a compile error in the last line of CopyCell.
Option Explicit
Dim wd As New Word.Application
Dim DataCell As Range
Sub ReportData()
'Open word template
wd.Documents.Open (Range("D4") & Range("D5"))
wd.Visible = True
'Creates range with all of the data used in the report
Dim DataRange As Range
Range("D7").Select
Set DataRange = Range(ActiveCell, ActiveCell.End(xlDown))
'Uses copycell function. "Name" is the bookmark name, 0 is the Rowoffset
For Each DataCell In DataRange
CopyCell "Name", 0
CopyCell "Employer", 1
Next
End Sub
Sub CopyCell(BookMarkName As String, RowOffset As Integer)
Dim BMRange As Word.Range
wd.Selection.GoTo What:=wdGoToBookmark, Name:=BookMarkName
Set BMRange = wd.Selection.Range.Duplicate
BMRange.Text = DataCell.Offset(RowOffset, 0).Value
wd.Bookmarks.Add BookMarkName, BMRange
End Sub

Bookmarks is a property of a Document object not of Word Application object
so you have to change:
wd.Bookmarks.Add BookMarkName, BMRange
to:
wd.ActiveDocument.Bookmarks.Add BookMarkName, BMRange
furthermore you may consider what follows:
you should limit the use of Public variable to where strictly unavoidable (e.g.: to communicate with UserForms)
avoid the Activate/ActiveXXX/Selection/Select pattern and use fully qualified range references
you're iterating through a "vertical" range and then you're offsetting current cell "vertically" (i.e. one cell down) again: may be you wanted to offset "horizontally" (i.e. to the adjacent cell)?
for all what above I'd propose the following refactoring of your code:
Option Explicit
Sub ReportData()
Dim wd As Word.Application
Dim DataCell As Range
Set wd = New Word.Application
'Open word template
wd.Documents.Open Range("D4") & Range("D5")
wd.Visible = True
'Creates range with all of the data used in the report
With Range("D7")
'Uses copycell function. "Name" is the bookmark name, 0 is the Rowoffset
For Each DataCell In Range(.Cells, .End(xlDown))
CopyCell wd, DataCell, "Name", 0
CopyCell wd, DataCell, "Employer", 1
Next
End With
wd.ActiveDocument.Close True '<--| close and save word document
wd.Quit '<--| close word application
Set wd = Nothing '<--| clean memory
End Sub
Sub CopyCell(wd As Word.Application, DataCell As Range, BookMarkName As String, ColOffset As Integer)
Dim BMRange As Word.Range
wd.Selection.GoTo What:=wdGoToBookmark, Name:=BookMarkName
Set BMRange = wd.Selection.Range.Duplicate
BMRange.Text = DataCell.Offset(0, ColOffset).Value
wd.ActiveDocument.Bookmarks.Add BookMarkName, BMRange
End Sub

Related

Copy Table Rows From Word Document To Existing Document Table Specific Cell

I am looking for a macro that will copy contents from a table in one word document to a table in another existing word document into a specific cell.
Start at row 5 and copy all rows following and paste it to the 5th row in the existing document.
Is this possible?
enter image description here
Sub ExtractTable()
Dim objTable As Word.Table
Dim tbls As Word.Tables
Dim objDoc As Document
Dim objNewDoc As Document
Dim objRange As Range
Set objDoc = ActiveDocument
Set tbls = objDoc.Tables
Set objNewDoc = Documents.Add("C:\dcam\Setup Sheets\lineup-sheet-template.html")
For Each objTable In tbls
Set objRange = objDoc.Range(Start:=objTable.Cell(5, 1).Range.Start, _
End:=objTable.Cell(25, 1).Range.End)
objRange.Select
Selection.Copy
Next
Set objRange = objNewDoc.Tables(1).Cell(5, 1).Range
objRange.Collapse Direction:=wdCollapseEnd
objRange.Paste
End Sub
If these are empty rows in the destination, why are they there when you could simply use either the FormattedText method or the PasteAppendTable method to add the rows to the destination table?
If there is something below the last row to be replicated, you could simply split the destination table in two and use either of the above methods to both add the rows to the 'top' destination table and join both parts at the split.
I have added comments to your code to indicate where you need to really think about what you are doing and why.
You also need to learn how to use the research tools at your fingertips - particularly the Object Explorer and online help.
Sub ExtractTable()
Dim objTable As Word.Table
Dim tbls As Word.Tables
Dim objDoc As Document
Dim objNewDoc As Document
Dim objRange As Range
Set objDoc = ActiveDocument
Set tbls = objDoc.Tables
Set objNewDoc = Documents.Add("C:\dcam\Setup Sheets\lineup-sheet-template.html")
'Why are you looping through all the tables?
'If you do this only the last one will be available on the clipboard
For Each objTable In tbls
'Are you only copying the cells in the first column? Or, does the table only have one column?
' Set objRange = objDoc.Range(Start:=objTable.Cell(5, 1).Range.Start, _
' End:=objTable.Cell(25, 1).Range.End)
Set objRange = objDoc.Range(Start:=objTable.Cell(5, 1).Range.Start, _
End:=objTable.Cell(objTable.Rows.Count, objTable.Columns.Count).Range.End)
'Why are you selecting the range when the Range has a Copy method?
' objRange.Select
' Selection.Copy
objRange.Copy
Next
Set objRange = objNewDoc.Tables(1).Cell(5, 1).Range
'Why are you collapsing the range to the end?
'This will cause the paste to be in column 2 as the range is now positioned at the end of cell marker
' objRange.Collapse Direction:=wdCollapseEnd
' objRange.Paste
objRange.PasteAppendTable
End Sub
Sub ExtractTable()
Dim oTable As Word.Table
Dim oDoc As Document
Dim oNewDoc As Document
Dim oRange As Range
Set oDoc = ActiveDocument
Set oNewDoc = Documents.Add("C:\dcam\Setup Sheets\lineup-sheet-template.html")
Set oTable = oDoc.Tables(1)
If oDoc.Tables.Count >= 1 Then
With oTable
Set oRange = oDoc.Range(Start:=oTable.Cell(5, 1).Range.Start, _
End:=oTable.Cell(oTable.Rows.Count, oTable.Columns.Count).Range.End)
oRange.Copy
End With
End If
Set oRange = oNewDoc.Tables(1).Cell(5, 1).Range
oRange.PasteAppendTable
End Sub

copy excel cell and paste it to specific word doc

I'm new to VBA and I need to copy one cell (that contains Data) from excel to a specific (not from a template) word document. the full path of the specific file will be in a cell next to the targeted cell - offset(0,1). All of that obviously in a loop because I have a big list and a lot of files.
this is my code (the code is made of some part I picked up while searching) - but I get an
object error
Sub OpenWordFile()
Dim oWord As Object
Dim xRg As Object
Dim xCell As Range
Dim xVal As Range
Dim Workbook As Workbook
Dim FileName As Variant
'Word Object
Set oWord = CreateObject(Class:="Word.Application")
oWord.Visible = True
'Open Word Document (need to be multiple files in a loop)
'oWord.documents.Open FileName:="C:\Users\tamirre\Desktop\New folder\135-185844.doc" ' OPEN AN EXISTING FILE.
'Set oWord = Nothing
'Activating Excel to copy Cells
ThisWorkbook.Worksheets("Sheet1").Activate
Set xRg = Application.InputBox("Please select Cells to copy to word docs:", ActiveWindow.RangeSelection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
For Each xCell In xRg
xVal = xCell.Value
Set FileName = xVal.Offset(0, 1) 'Cell Must Contain name and full path of the doc file
xVal.Copy
oWord.documents.Open FileName:="FileName"
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
Selection.PasteExcelTable True, False, False
Next
End Sub
InputBox returns a String, not an Object.
Change the Dim line to this:
Dim xRg As String
and change the InputBox lines to this:
xRg = InputBox("Please select Cells to copy to word docs:", "Range Selection", ActiveWindow.RangeSelection.Address)
If xRg ="" Then Exit Sub
Then if you want to turn it into a Range object:
Dim xRange As Object
Set xRange = Range(xRg)
However, I do not recommend doing what you are doing this way. There are too many chances the user will enter something invalid and you will get errors.

Word VBA - Returning the bookmark by finding Text

I'm trying to write some VBA with a Microsoft Word Document that will search for a text string within itself, and once it has found it, will return the preceding bookmark name.
I currently have the below code;
Public Sub FindDocument()
Dim wrdThis As Document
Dim strSearch As String
Dim myRange As Range
Dim lngBookMark As Long
Dim lngHeadingName As Long
Dim varBookmarks As Variant
Dim i As Integer
Set wrdThis = ThisDocument
Set myRange = wrdThis.Content
strSearch = "ID: VTER"
varBookmarks = wrdThis.GetCrossReferenceItems(wdRefTypeBookmark)
myRange.Find.Execute FindText:=strSearch, Forward:=True
If myRange.Find.Found = True Then
lngBookMark = myRange.BookmarkID
MsgBox "Search text found in bookmark " & varBookmarks(lngBookMark)
End If
End Sub
I can't seem to get the code to return a unique identifier for the preceding bookmark as the text I am searching for will be found between 2 bookmarks.
Any help would be greatly appreciated.
The only way, really, to pick up bookmarks is to query them from a Range. In your case, you need the Range from the Found range backwards. Simplest would simply be to set the Range back to the start of the Document, then pick up the last bookmark. The following code sample, based on your original, illustrates this.
Note that I've changed ThisDocument to ActiveDocument. ThisDocument is the document object in which your VBA code resides. I'm assuming you want the code to run on whichever document is currently being worked on? In that case, ActiveDocument is correct.
Sub FindThenPrevBookmark()
Dim wrdThis As Document
Dim strSearch As String
Dim myRange As Range, rngToStart As word.Range
Dim bkm As word.Bookmark
'Dim lngBookMark As Long
'Dim lngHeadingName As Long
'Dim varBookmarks As Variant
'Dim i As Integer
Set wrdThis = ActiveDocument
Set myRange = wrdThis.content
strSearch = "Home"
'Ensure that Execute and Found are performed on the same FIND
With myRange.Find
.Execute findText:=strSearch, Forward:=True
If .found = True Then
'Always use DUPLICATE to "copy" a Range object!
Set rngToStart = myRange.Duplicate
rngToStart.Start = wrdThis.content.Start
If rngToStart.Bookmarks.Count > 0 Then
Set bkm = rngToStart.Bookmarks(rngToStart.Bookmarks.Count)
MsgBox "Search text found in bookmark " & bkm.Name
End If
End If
End With
End Sub

Finding Matches between an Excel Spreadsheet and VBA Array

I'm new to Excel VBA and was looking for some help in fixing my code. So basically to provide colour on what I have, I have an excel database, and a word document. In the word document I have bookmarked section headers (reffered to as "cat", "dog", and "bird") and in a row on the excel database I have "dog" and "bird".
What I am trying to do is write a code that compares the elements of the array (which are strings) to the cell values within a range declared in an excel database. For the values that exist in the array but not in the declared excel range, I want to delete those values (i.e. the bookmark) from the word document.
If anyone could provide me with feedback, ideas, or example codes it would be greatly appreciated.
Thanks.
Sub ArrayToDatabase()
Dim myRange As Variant
Set myRange = Range("C7:AP7")
Dim myArray As Variant
myArray = Array("cat", "dog", "bird")
Dim i As Integer
Dim reqName As Object
For i = LBound(myArray) To UBound(myArray)
Set reqName = myArray(i).Value
If myRange.Validation(reqName) = False Then
wdApp.ActiveDocument.Bookmarks(reqName).Range._
Paragraphs(1).Range.Delete
End If
Next i
End Sub
Logic
Use .Find to check if the keywords are present in the range or not.
Store the relevant keywords in a comma delimited string which will later be converted into an array
Open word doc
Loop through the array and delete the bookmarks
Is this what you are trying?
Option Explicit
Sub Sample()
Dim myArray As Variant, BookMarksToDelete As Variant
Dim oWordApp As Object, oWordDoc As Object
Dim sTemp As String, FlName As String
Dim aCell As Range, myRange As Range
Dim i As Long
'~~> Change this to the relevant sheet
Set myRange = ThisWorkbook.Sheets("Sheet1").Range("C7:AP7")
myArray = Array("cat", "dog", "bird")
'~~> Change this to the relevant word document
FlName = "C:\Users\Siddharth\Desktop\DeleteMeLater.docx"
For i = LBound(myArray) To UBound(myArray)
'~~> Check if the word exists in the range or not
Set aCell = myRange.Find(What:=myArray(i), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If it doesn't then store it in a comma delimited string
If aCell Is Nothing Then
sTemp = sTemp & "," & myArray(i)
Else
Set aCell = Nothing
End If
Next i
sTemp = Mid(sTemp, 2)
If Not Len(Trim(sTemp)) = 0 Then
'~~> Convert comma delimited string to array
BookMarksToDelete = Split(sTemp, ",")
'~~> Open word document
Set oWordApp = CreateObject("Word.Application")
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(FlName)
'~~> Delete the bookmarks
For i = LBound(BookMarksToDelete) To UBound(BookMarksToDelete)
oWordDoc.Bookmarks(BookMarksToDelete(i)).Delete
Next i
End If
MsgBox "Done"
End Sub
Does your code work? It's a little unclear what you're asking, unless that's just for feedback. All I personally have to say is the way you declare variables.
So if you know what the variable will hold, it's best to declare it as such. For example,
Dim myRange as Range
Dim myArray(2) as String
myArray = {"cat", "dog", "bird"}
Dim reqName as String
I'm no expert either, just trying to help! Feel free to ask any questions, but I can't guarantee I have an answer.

Copying multiple ranges from excel to word and controlling linespacing

I manage to copy a range from excel to a newly opened WORD document and control the line spacing (thanks to some help Copy range from excel to word - set paragraph spacing to zero).
However, I do not manage to control the linespacing when I copy multiple ranges to multiple bookmarks in an opened and existing word file (document.docx). The code can be found below at the end of the post.
This code works for an excel file with multiple sheets. One sheet is a configuration sheet. It contains the name of the excel sheet containing the table (in range "Name") and links this to the bookmark name in word (in range BookmarkExcel")".
I suppose the problem is with this piece of the code:
Set wdTable = myDoc.Tables(myDoc.Tables.Count)
wdTable.Range.ParagraphFormat.SpaceAfter = 0
I tried all sorts of variations (e.g. replacing myDoc.Tables.Count by rep, 1, ...) but didn't manage to control the linespacing. What did I do wrong?
EDIT: I found the cause: the document contains already some tables (before and after the ones that I copy and paste) which causes the code for the line spacing not to work. Thus, how can I adapt my code such that it works for documents that already contain tables?
Sub ExcelTablesToWord()
Dim tbl As Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Sheets("Configuration").Select
n = ActiveSheet.UsedRange.Rows.Count
Set ListTables = Range("Name")
Set ListExcelBookmarks = Range("BookmarkExcel")
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("document.docx")
For rep = 2 To n
SheetName = ListTables.Cells(rep, 1).Value
On Error Resume Next
Set existing = Sheets(SheetName)
existing.Select 'added this
lastColumn = ActiveSheet.UsedRange.Columns.Count
LastRow = ActiveSheet.UsedRange.Rows.Count
If ListExcelBookmarks.Cells(rep, 1).Value <> "" Then
Set tbl = Range(Cells(1, 1), Cells(LastRow, lastColumn))
tbl.Copy
myDoc.Bookmarks(ListExcelBookmarks.Cells(rep, 1).Value).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
Dim wdTable As Table
Set wdTable = myDoc.Tables(myDoc.Tables.Count)
wdTable.Range.ParagraphFormat.SpaceAfter = 0
End If
Next rep
End Sub
count the tables up to current bookmark and then add one to get the newly added table index
here's your code with what above and some other (hopefully) useful refactoring:
Option Explicit
Sub ExcelTablesToWord()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim wdTable As Table
Dim rep As Long
Dim ListTables As Range
Dim ListExcelBookmarks As Range
Dim ws As Worksheet
Dim tabName As String
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("document.docx")
With Worksheets("Configuration")
Set ListTables = .Range("Name")
Set ListExcelBookmarks = .Range("BookmarkExcel")
End With
For rep = 2 To ListExcelBookmarks.Rows.Count '<--| loop through bookmarks range, skipping first row
If ListExcelBookmarks.Cells(rep, 1).Value <> "" Then
tabName = ListTables.Cells(rep, 1).Value
If GetSheet(tabName, ws) Then '<-- GetSheet() returns 'True' if a worksheet named after 'tabName' is found and sets 'ws' to it. Otherwise it returns 'False'
ws.UsedRange.Copy
With myDoc
.Bookmarks(tabName).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
Set wdTable = .Tables(.Range(.Range.Start, .Bookmarks(tabName).Range.End).Tables.Count + 1) '<--| add one to the tables before current bookmark to get the newly added one right after it
wdTable.Range.ParagraphFormat.SpaceAfter = 0
End With
End If
End If
Next rep
End Sub
Function GetSheet(shtName As String, ws As Worksheet) As Boolean
On Error Resume Next
Set ws = Worksheets(shtName)
GetSheet = Not ws Is Nothing
End Function