Referring Excel objects which embedded in a MS-Word Document? - vba

I have many Excel objects are there embedded in a MS-Word Document.
I want to calculating the grand total: with summing the totals are there in the each specified excel object and return that grand total in the MS-Word document.
Macro holder is MS-Word Document's VBA module.
Means: I need to access to an specified embedded Excel object, form the MS-Word module, then perform it active, then assign to an object-variable by -For example:- ExcelApplication = GetObject(, "Excel.Application") statement. Then try to access its appropriated total values , by -For example:- Total = Range("Table1[[#Totals],[Amount]]").Value. Point is all tables Name are in the Excel objects is Table1 which contains the Amount Columns and the Total Row.
Note is in above Excel objects, The first row which contains the Table Header is Hided.
Example
Sample File
This document have extending daily.
I need a macro in the Normal.dotm Which calculating the grand total of all specified Excel object (specified with assigning a name to them or ...) and perform returning this value with Selection.TypeText Text:= where is selected in picture below: (at the end of document)
Why I insist to have embedded Excel object?
Because I have formula for calculating Column1: A, B, C, ....
Because I have a hided Data base Sheet for data validation Items
I have Formula in Amount column for multiplying the rates and the
amount of each item-unit which is in Data base sheet

In that case, try something along the lines of:
Sub TallyXLVals()
Application.ScreenUpdating = False
Dim Rng As Range, objOLE As Word.OLEFormat, objXL As Object
Dim i As Long, lRow As Long, sValA As Single, sValB As Single, sValC As Single
Const xlCellTypeLastCell As Long = 11
With ActiveDocument
.ActiveWindow.Visible = False
For i = .InlineShapes.Count To 1 Step -1
With .InlineShapes(i)
If Not .OLEFormat Is Nothing Then
If Split(.OLEFormat.ClassType, ".")(0) = "Excel" Then
Set Rng = .Range
Set objOLE = .OLEFormat
objOLE.Activate
Set objXL = objOLE.Object
With objXL.ActiveSheet
lRow = .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
sValA = sValA + .Range("A" & lRow).Value
sValB = sValB + .Range("B" & lRow).Value
sValC = sValC + .Range("C" & lRow).Value
End With
objXL.Application.Undo
End If
End If
End With
Next
Call UpdateBookmark("BkMkA", Format(sValA, "$#,##0.00"))
Call UpdateBookmark("BkMkB", Format(sValB, "$#,##0.00"))
Call UpdateBookmark("BkMkC", Format(sValC, "$#,##0.00"))
.ActiveWindow.Visible = True
End With
Set objXL = Nothing: Set objOLE = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Sub UpdateBookmark(StrBkMk As String, StrTxt As String)
Dim BkMkRng As Range
With ActiveDocument
If .Bookmarks.Exists(StrBkMk) Then
Set BkMkRng = .Bookmarks(StrBkMk).Range
BkMkRng.Text = StrTxt
.Bookmarks.Add StrBkMk, BkMkRng
End If
End With
Set BkMkRng = Nothing
End Sub
where the locations you want the outputs to appear are bookmarked, with the names BkMkA, BkMkB, & BkMkC, respectively.
Note: Because you're activating embedded objects, there is unavoidable screen flicker.

Your own effort is insufficent. Here is code to start you off. The code will loop through all the InlineShapes in your Word document, select the first one which represents an Excel worksheet and opens that item for editing. It is the same action which you can recreate in the document by right-clicking on the embedded Excel table, selecting "Worksheet Object" and "Edit".
Private Sub OpenEmbeddedExcelInWord()
' 08 Jan 2018
Dim Shp As InlineShape
For Each Shp In ActiveDocument.InlineShapes
With Shp
If Shp.Type = wdInlineShapeEmbeddedOLEObject Then Exit For
End With
Next Shp
Shp.OLEFormat.Edit
End Sub

Related

Macro emailing all but two worksheets

I have a workbook that contains sheets of price lists for different customers, and each week I have to email all the pricelists to the corresponding customers. This is a fairly time-consuming task and I have been trying to automate it with VBA. For the most part, I have succeeded by using Ron de Bruin's code but I have run into an issue that I can't seem to solve so I'm for hoping some insight as to where I've gone wrong.
As previously mentioned this workbook contains multiple, different, price sheets that all need to be sent to different customers. I have modified this code slightly to meet my needs (e.g. only coping visible cells, to include the email signature, etc...). One major change I made to this code is that I loop through a range that contains the recipients' addresses (which can be seen below).
The problem that I'm currently facing is that this code works for all but two sheets. It will create an email for the two problem sheets, but nothing in the range (A1:L85) will be pasted into the email - it just sends an email with no body besides my signature. What makes this worse (or more interesting) is that these two problem sheets occur in the "middle" of the worksheets. Let's say problem sheet 1 = PS_1 and problem sheet 2 = PS_2 it would be like this:
WS_1, WS_2, ..., WS_14, PS_1, WS_16, PS_2, WS_18, ..., WS_32
So I'm wondering why it's only messing up on these two sheets, and how to fix it.
I have included all my code below (except for RangetoHTML which is on Ron de Bruin's website, and a function to that gets the worksheet names):
Sub email()
' this is intended to speed up the code
With Excel.Application
.ScreenUpdating = False
.Calculation = Excel.xlCalculationManual
.EnableEvents = False
End With
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range 'this is the range of the price list
Dim erng As Range 'this is the range of email addresses
Dim cell As Range
Dim wsnames() As String 'worksheet names are stored in an array
Dim pricedate As String 'the week of prices the user provides (e.g. July 1st - July 7th)
Dim tsheets As Integer 'total sheets
'counting variables
Dim m As Integer
Dim n As Integer
Set OutApp = CreateObject("Outlook.Application")
'initializing variables
Set rng = Nothing
'initializing variables
n = 0
pricedate = InputBox("Enter the week the prices are for (e.g. July 10th - July 15th): ", "Week")
If pricedate = vbNullString Then Exit Sub 'if the user presses cancel it will stop the macro
tsheets = ActiveWorkbook.Worksheets.Count 'finds how many sheets are in the workbook to adjust the size of the array
ReDim wsnames(tsheets) 'resizes the size of the array
wsnames = storewsnames 'passing the sheet names to wsnames
For m = 1 To tsheets - 1
If wsnames(m) = "Atwood" Then Exit For 'looks for the index of worksheet "Atwood", and once it's found it exits the loop
Next m
For n = m To tsheets - 1 'sets n to the index of "Atwood"
If Sheets(wsnames(n)).Visible = True Then 'only will send emails to visible sheets
With Sheets(wsnames(n))
Set rng = .Range("A1:L85")
Set erng = .Range("M71:M85")
End With
On Error GoTo cleanup
For Each cell In erng 'searches the cells in the email addresses range
If cell.Value Like "?*#?*.?*" Then 'looks
'_for email addresses where the email addresses are saved
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
.To = ""
.CC = ""
.BCC = cell.Value
.Subject = "CM Weekly Prices - " & wsnames(n)
.HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri> Hi, " & _
"<br><br>" & "Below are the prices for the week of " & pricedate & _
"." & RangetoHTML(rng) & "Thank you, </BODY><br>" & .HTMLBody
.Send
End With
On Error GoTo cleanup
Set OutMail = Nothing
End If
Next cell
End If
Next n
' this is intended to speed up the code
With Excel.Application
.ScreenUpdating = True
.Calculation = Excel.xlCalculationAutomatic
.EnableEvents = True
End With
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I'm very unfamiliar with using VBA to send an email so I have been heavily reliant on the code I have used and have tried to only make minor-ish changes.
If there is anything else you folks need, or something is unclear please let me know!

Transferring data from excel to MS word

I need a VBA code to update my word file. It which consists of some tables That has to be updated from excel file. Excel file consists of bearing data with different bearing numbers. And my report has to be updated with the bearing values. Like for my next report if I just enter the different bearing file it must read all the bearing data from that file.
This has to be done in 3 steps. I have attached a sample image. firstly identify the bearing name which is always in A column (In this case I need to find (248_R), 38,7 % ). Then select 6*6 matrix data (suppose I find the bearing data to be in A946 then I need to record data from B950 to G955) and then transfer to word file(Only the values to the table). I am a newbee in VBA coding please can someone help?
image of sample bearing name with matrix underneath
Image of what the tables look like in the word document:
The first part of copying the range you want is relatively easy. You can use the following code to copy your desired matrix. I am not sure about pasting to a word document yet, give me some more time on that.
(For now, if you run this macro, the range you want will be copied. You can then switch to your word document and hit Ctrl+V to paste it into the desired table.
Also, please check and see whether the following references have been added:
Option Explicit
Sub findBearingDataAndPasteToWord()
Dim i As Integer
Dim aCell As Range, rng As Range
Dim SearchString As String
Set rng = Range("A750:A1790")
SearchString = "(248_R), 38,7 %"
For Each aCell In rng
If InStr(1, aCell.Value, SearchString, vbTextCompare) Then
ActiveSheet.Range(Cells(aCell.row + 4, 1), Cells(aCell.row + 9, 6)).Copy
Dim wrdApp As Word.Application
Dim docWd As Word.Document
MsgBox "Please select the word document that you want to paste the copied table data into (after pressing OK)" & _
vbNewLine & vbNewLine & "Script written by takanuva15 with help from Stack Overflow"
docFilename = Application.GetOpenFilename()
If docFilename = "False" Then Exit Sub
Set docWd = getDocument(docFilename)
Set wrdApp = docWd.Application
wrdApp.Selection.EndKey Unit:=wdStory
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
wrdApp.Selection.PasteExcelTable False, True, False
Exit Sub
Else: End If
Next aCell
End Sub
'Returns the document with the given filename
'If the document is already open, then it returns that document
Public Function getDocument(ByVal fullName As String) As Word.Document
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Dim fileName As String
Dim docReturn As Word.Document
fileName = Dir(fullName)
Set docReturn = Word.Documents(fileName)
If docReturn Is Nothing Then
Set docReturn = Word.Documents.Open(fullName)
End If
On Error GoTo 0
Set getDocument = docReturn
End Function

VBA Type missmatch

I have wrote some VBA code which I was fairly happy with. It went through a list on a worksheet, switched to another and set a variable (and thus changed some graphs) and then opened word, copied in the graphs to various bookmarks and saved the document as the variable name.
It worked like a charm and I was a happy boy (saved a good week and a bit of work for someone). I have not touched it since - or the worksheets for that matter - opened it today and it is giving me a type missmatch on the first lot. I would really love some advice as it has left me scratching my head.
Public X As Integer
Public Y As String
Sub Macro2()
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Sheets("CPD data 13-14").Select
Range("A" & LoopCounter).Select
Y = Range("A" & LoopCounter).Value
'Change the chart values
Sheets("Pretty Display (2)").Select
Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
The error hits on the following line:
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
EDIT
As suggested I have updated my code not to use select so it now reads:
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
'Change the chart values
pd.Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = pd.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
I still get the same runtime error at the same point.
try this
Option Explicit
Public X As Integer
Public Y As String
Sub Macro2()
Dim wordApp As Object
Dim LoopCounter As Integer
Dim Mystring As String
Dim ws As Worksheet, pd As Worksheet
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
' open one Word session for all the documents to be processed
Set wordApp = CreateObject("word.Application")
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
With pd
.Range("A1").Value = Y 'Change the chart values
.ChartObjects("Chart 3").Copy ' Copy the chart
End With
'act on Word application
With wordApp
'open word template
.documents.Open "LOCATION"
.Visible = True
' paste into bookmarks, "save as" document and close it
With .ActiveDocument
.Bookmarks("InstitutionName").Range = Y
.Bookmarks("Graph1").Range.PasteSpecial
Mystring = Replace(Y, " ", "")
.SaveAs Filename:="LOCATION" & Mystring & ".docx"
.Close
End With
End With
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
'Close Word
wordApp.Quit
Set wordApp = Nothing
End Sub
I couldn't have a word "Range" object directly set to an Excel "Chart" object
So I had to copy the chart and use "PasteSpecial" method of the Word "Range" object
Furthemore I worked with one Word session only, which'd result in a faster job
Finally I also made some "comsetics" to make the code more readable/maintanable
just as a suggestion: I'd always use "Option Explicit" statement. that'll force you some extra work to explicitly declare each and every variable you use, but that will also give much more control over your work and result in less debbugging issues, thus saving time at the end
My advice is to set the Explicit flag and try to decompile the code. Any variables that you didn't dimension will throw an error. This is a good time to dimension the variable and type the data appropriately.
If that doens't throw an error, which it should since you have at least one variable LoopCounter that isn't dimensioned and could therefore cause data type errors then try changing Public X As Integer to Public X As Long so as to avoid values beyond the limit of the Integer data type.
.Activate is sometimes necessary even when using .Select from my experience. Selecting a worksheet should make it the active worksheet, but that's not always the case.

Merge data in Excel to multiple Word documents

I would need some help from you to complete this VBA I have. What should I do with it if I would want the text to stay the same like it was in the excel file where it had different fonts, sizes and colors? And how should i edit the VBA to make it jump a extra row before pasting the data?
For example:
ITEM ID: 551555
IN STOCK: 14
Instead of
ITEM ID: 551555
IN STOCK: 14
Sub Copy2Word()
Const lngHeaderRow = 1
Const lngFirstRow = 2
Dim lngLastRow As Long
Dim lngRow As Long
Const lngFirstCol = 1
Dim lngLastCol As Long
Dim lngCol As Long
Dim objWord As Object
Dim objDoc As Object
Dim objRng As Object
On Error Resume Next
Set objWord = GetObject(Class:="Word.Application")
If objWord Is Nothing Then
Set objWord = CreateObject(Class:="Word.Application")
If objWord Is Nothing Then
MsgBox "Cannot start Word!", vbExclamation
Exit Sub
End If
End If
On Error GoTo 0
objWord.ScreenUpdating = False
Set objDoc = objWord.Documents.Add
lngLastRow = Cells(Rows.Count, lngFirstCol).End(xlUp).Row
lngLastCol = Cells(lngHeaderRow, Columns.Count).End(xlToLeft).Column
For lngRow = lngFirstRow To lngLastRow
Application.StatusBar = "Processing row " & lngRow & " of " & lngLastRow
For lngCol = lngFirstCol To lngLastCol
objDoc.Content.InsertAfter Cells(lngHeaderRow, lngCol) & ": " & Cells(lngRow, lngCol)
If lngCol < lngLastCol Then
objDoc.Content.InsertParagraphAfter
End If
Next lngCol
If lngRow < lngLastRow Then
Set objRng = objDoc.Content
objRng.Collapse Direction:=0 ' wdCollapseEnd
objRng.InsertBreak 7 ' wdPageBreak
End If
Next lngRow
Application.StatusBar = False
objWord.ScreenUpdating = True
objWord.Visible = True
End Sub
Use the Excel Macro recorder to change some sample text to the different fonts, sizes, foreground and background colors you are interested in using. The code will work the same in a MS Word document except the word text has different syntax than that found in Excel. (Google MS Word VBA change font color to get examples)
The date and numeric formats can be set using the format command. Read up on it.
Also Google MS Word VBA for moving right/down a character, word, or paragraph on how to force a new line.
The MS Word object model is harder to work with if you don't know it. I spend a lot of time testing out different code via the Immediate window. It takes a fair amount of trial and error to get everything working, due to the free form nature of a Word doc, vs. content in an Excel cell.
Good luck!

mulitiple files to extract a similar word table from each to excel VBA

I have in excess of 300 word documents that include word tables, and I have been trying to write a VBA script for excel to extract the information I need, and I am completely new to Visual Basic. I need to copy the file name to the first cell, and the following cells to contain the information I am trying to extract, followed by the next file name, looping on until all word documents have been searched and extracted. I have tried multiple different ways, but the closest code I can find is as follows. It works to pull part numbers, but not descriptions. It also pulls extraneous information that doesn't need to be there, but I can work around that information if it is a necessary hazard.
I have an example word file (replaced sensitive information with other information), but I am not sure how to attach the word document or jpegs of page 1 and 2 of the word document. I know it would be beneficial if you could see it, so please let me know how to get it on here or to you so you can see it.
So to re-iterate:
I need the file name in the first cell (A1)
I need a certain cell out of table 3 from a word document to excel
If at all possible, I need descriptions in column B (B2:B?) and
mixture of letters and numbers in column C (C2:C?), then on the next
line down, the next file name (A?), and continue to repeat. If you
have any ideas, or suggestions, please let me know. And if I can't
post the picture, or the actual sample document, I am willing to
email, or any other means necessary to get help on this.
Here is the code I have been trying to manipulate. I found it and it was for a first and last row of a form, and I tried to get it to work, for my purposes to no avail:
Sub GetTablesFromWord()
'this Excel file must be in
'the same folder with the Word
'document files that are to be'processed.
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim wTable As Word.Table
Dim wCell As Word.Cell
Dim basicPath As String
Dim fName As String
Dim myWS As Worksheet
Dim xlCell As Range
Dim lastRow As Long
Dim rCount As Long
Dim cCount As Long
Dim RLC As Long
Dim CLC As Long
basicPath = ThisWorkbook.Path & Application.PathSeparator
'change the sheet name as required
Set myWS = ThisWorkbook.Worksheets("Sheet1")
'clear any/all previous data on the sheet myWS.Cells.Clear
'"open" Word Set wApp = CreateObject("Word.Application")
'get first .doc file name in the folder
'with this Excel file
fName = Dir(basicPath & "*.doc*")
Do While fName <> ""
'this puts the filename into column A to
'help separate the table data in Excel
myWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = _
"FILE: [" & fName & "]"
'open the Word file
wApp.Documents.Open basicPath & fName
Set wDoc = wApp.Documents(1)
'if there is a table in the
'Word Document, work with it
If wDoc.Tables.Count > 0 Then
Set wTable = wDoc.Tables(3)
rCount = wTable.Rows.Count
cCount = wTable.Columns.Count
For RLC = 1 To rCount
lastRow = myWS.Range("A" & Rows.Count).End(xlUp).Row + 1
For CLC = 1 To cCount
'if there are merged cells in the
'Word table, an error will be
'generated - ignore the error,
'but also won't process the data
On Error Resume Next
Set wCell = wTable.Cell(RLC, CLC)
If Err <> 0 Then
Err.Clear
Else
If CLC = 1 Then
Set xlCell = myWS.Range("A" & lastRow)
xlCell = wCell
Else
Set xlCell = myWS.Range("B" & lastRow)
xlCell = wCell
End If
End If
On Error GoTo 0
Next
Next
Set wCell = Nothing
Set wTable = Nothing
End If ' end of wDoc.Tables.Count test
wDoc.Close False
Set wDoc = Nothing
fName = Dir()
' gets next .doc* filename in the folder
Loop wApp.Quit
Set wApp = Nothing
MsgBox "Task Completed"
End Sub
This code loops through all of the .docx files contained within a folder, extracts data into your spreadsheet, closes the word document, and moves onto the next document. The name of the word document gets extracted into Column A, and a value from within the 3rd table in the document is extracted into Column B. This should be a good starting point for you to build upon.
Sub wordScrape()
Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files
x = 1
For Each wd In objFiles
If InStr(wd, ".docx") And InStr(wd, "~") = 0 Then
Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)
sh1.Cells(x, 1) = wd.Name
sh1.Cells(x, 2) = Application.WorksheetFunction.Clean(wrdDoc.Tables(3).Cell(Row:=3, Column:=2).Range)
'sh1.Cells(x, 3) = ....more extracted data....
x = x + 1
wrdDoc.Close
End If
Next wd
wordApp.Quit
End Sub