ShawnExcel
Member
I want code that simply:
Here is what I have so far (borrowed code) - it is most of the way there but it needs a bit of work. Anyone able to help?
Thanks!
- Uses the active Excel Document (all sheets)
- Allows you to identify a word template (on a server/desktop)
- Using that Word Template, it loops through each named range in Excel and each bookmark in Word and IF there is an exact match, it places ONLY the text from Excel (no formatting) into the Word document
- If there is a match between bookmarks but the Excel range is blank, it should delete the whole line in Word.
Here is what I have so far (borrowed code) - it is most of the way there but it needs a bit of work. Anyone able to help?
Thanks!
Code:
Sub RefreshAllTables()
''==============================================================================
''Purpose: To refresh the current table in a Word document with new data from
'' the corresponding range in an Excel document.
''The code uses bookmarks in the Word document and corresponding named ranges in
'' Excel. The Excel data is brought in as pictures. This has the advantage that any
'' formatting in the Excel document is retained, and the dimensions don't change
'' significantly.
'' Also, bookmarks are simpler to create and maintain because a picture is only a
'' single character in a Word document.
''Requires: A table in the Excel file to line up the bookmarks and named ranges
''Created: 23 Oct 2008 by Denis Wright
''==============================================================================
Dim objExcel As Object, _
objWbk As Object, _
objDoc As Document
Dim sBookmark As String, _
sWbkName As String
Dim sRange As String, _
sSheet As String
Dim BMRange As Range
Dim bmk As Bookmark
Dim i As Integer, _
j As Integer, _
k As Integer, _
bmkCount As Integer
Dim vNames()
Dim vBookmarks()
Dim dlgOpen As FileDialog
Dim bnExcel As Boolean
On Error GoTo Err_Handle
Set dlgOpen = Application.FileDialog( _
FileDialogType:=msoFileDialogOpen)
bnExcel = False
Do Until bnExcel = True
With dlgOpen
.AllowMultiSelect = True
.Show
If .SelectedItems.Count > 0 Then
sWbkName = .SelectedItems(1)
Else
MsgBox "Please select a workbook to use for processing"
End If
End With
If InStr(1, sWbkName, ".xls") > 0 Then
'proceed
bnExcel = True
Else
MsgBox "The file must be a valid Excel file. Try again please..."
End If
Loop
Set objDoc = ActiveDocument
'check to see that the Excel file is open. If not, open the file
'also grab the wbk name to enable switching
Set objExcel = GetObject(, "Excel.Application")
For i = 1 To objExcel.Workbooks.Count
If objExcel.Workbooks(i).Name = sWbkName Then
Set objWbk = objExcel.Workbooks(i)
Exit For
End If
Next
If objWbk Is Nothing Then
Set objWbk = objExcel.Workbooks.Open(sWbkName)
End If
'minimize the Excel window
objExcel.WindowState = -4140 'minimized
'switch to Excel, find range name that corresponds to the bookmark
objExcel.Visible = False
objWbk.Activate
vNames = objWbk.Worksheets("Lists").Range("Bookmarks").Value
'loop through the bookmarks
bmkCount = ActiveDocument.Bookmarks.Count
ReDim vBookmarks(bmkCount - 1)
j = LBound(vBookmarks)
For Each bmk In ActiveDocument.Bookmarks
vBookmarks(j) = bmk.Name
j = j + 1
Next bmk
For j = LBound(vBookmarks) To UBound(vBookmarks)
'go to the bookmark
Selection.GoTo What:=wdGoToBookmark, Name:=vBookmarks(j)
Set BMRange = ActiveDocument.Bookmarks(vBookmarks(j)).Range
For k = 1 To UBound(vNames)
If vNames(k, 1) = vBookmarks(j) Then
sSheet = vNames(k, 2)
sRange = vNames(k, 3)
Exit For
End If
Next k
'copy data from the range as a picture
objWbk.Worksheets(sSheet).Range(sRange).CopyPicture 1, -4147
'return to Word and paste
objDoc.Activate
BMRange.Select
Selection.Delete
'Note: only required if the bookmark encloses a picture.
'If the bmk held text, deleting the selection removes the bmk too.
'Under those circumstances the code throws an error.
'Clunky workaround: tell Word to ignore the error
On Error Resume Next
ActiveDocument.Bookmarks(sBookmark).Delete
On Error GoTo 0
'paste the picture, then move back one character so the new bookmark
'encloses the pasted picture
Selection.PasteAndFormat (wdPasteDefault)
Selection.Move Unit:=wdCharacter, Count:=-1
'now reinstate the bookmark
objDoc.Bookmarks.Add Name:=vBookmarks(j), Range:=Selection.Range
Next j
Err_Exit:
'clean up
Set BMRange = Nothing
Set objWbk = Nothing
objExcel.Visible = True
Set objExcel = Nothing
Set objDoc = Nothing
MsgBox "The document has been updated"
Err_Handle:
If Err.Number = 429 Then 'excel not running; launch Excel
Set objExcel = CreateObject("Excel.Application")
Resume Next
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Err_Exit
End If
End Sub