copy excel cell and paste it to specific word doc - vba

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.

Related

To copy text from excel to word as sentence without cell borders

I have an excel with a specific column having text in multiple lines within each cells. I want to copy that multi-line text into word document as sentence in word format. I tried several codes but all that copies the excel range and pastes in word exactly the same way it is in excel including the cell borders. I do not want cell borders. I want text to be copied as a sentence/paragraph. Can someone please help me with this.
Here is the code i'm using:
Public Sub CommandButton1_Click()
On Error GoTo ErrorHandler
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application.8")
wApp.Visible = True
Const strPath1 As String = "D:\Template.docx"
Set wDoc = wApp.Documents.Add(Template:=strPath1, NewTemplate:=False, DocumentType:=0)
Worksheets("Sheet2").Range(ActiveCell, ActiveCell.End(xlDown)).Copy
With wDoc.Paragraphs(wDoc.Paragraphs.Count).Range
.Paste
End With
ErrorHandler:
Resume Next
End Sub
You don't want to use copy and paste, you need to use the Excel VBA object model to reference the cell you want and then access the text using cell.Value.
You must already be using Excel.Application, and you must already be referencing the cell since you copy and paste the value, so swap the code you have to copy and paste with the code to use the cell.value.
Unfortunately, I'm not at my computer so I can't test this, but you want to replace your code with something like
Public Sub CommandButton1_Click()
On Error GoTo ErrorHandler
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application.8")
wApp.Visible = True
Const strPath1 As String = "D:\Template.docx"
Set wDoc = wApp.Documents.Add(Template:=strPath1, NewTemplate:=False, DocumentType:=0)
Dim currentcell as variant
Dim result as string
For each currentcell in Worksheets("Sheet2").Range(ActiveCell, ActiveCell.End(xlDown))
Result =result & currentcell.value & vbcrlf
Next currentcell
With wDoc.Paragraphs(wDoc.Paragraphs.Count).Range
.Text= result
End With
ErrorHandler:
Resume Next
End Sub

Find shape in PPT and retreive text then search for that text in Excel, copy column then paste it back into PPT as a table

This is my first real attempt to create something in VBA, so be gentle please.
This is what I need my program to do:
Run from PPT and open an Excel file
Start at slide 1 and find a box that contains the words "iq_", if it
has those words then it will have numbers after it like so "iq_43"
or "iq_43, iq_56, iq_72".
find those words and numbers in the opened Excel file. Needs to
recognize that ", " means there is another entry.
Copy column containing words from ppt ie. "iq_43"
Paste a Table into ppt with those values
Do this for every slide
I'm having issues with my function at the bottom. This is where the program should be shifting to work in the opened excel file. The idea there is to go through the headers of each column and search for values that I have stored in "iq_Array". Once values are found, then copy rows below it into another array called "tble" (which will eventually be pasted onto the powerpoint slide as a table).
The code currently stops at
rng = Worksheets("Sheet1").Cells(1, i).Value
I'm not sure what I'm doing wrong here. Once fixed, will this is be able to be copied into an array?
Another part I believe I'm having trouble with is how to return the function values. I currently have
xlFindText(iq_Array, xlWB) = tble()
At the bottom of my function in order to call it as such in my main code. Is this the proper way to do it?
Public Sub averageScoreRelay()
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim pptSlide As Slide
Dim fileName As String
Dim Shpe As Shape
Dim pptText As String
Dim strArray As String
Dim pptPres As Object
Dim PowerPointApp As Object
Dim iq_Array
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("C:\Users\pinlop\Desktop\Gate\Macro\averageScores\pptxlpratice\dummyavgscore.xlsx", True, False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
'Is PowerPoint already opened?
'Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Make PPT visible
Set pptPres = PowerPoint.ActivePresentation
Set pptSlide = Application.ActiveWindow.View.Slide 'Set pptSlide = pptPres.Slides _
(PowerPointApp.ActiveWindow.Selection.SlideRange.SlideIndex) (different way of saying the same thing?)
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
'Identify if there is text frame
If Shpe.HasTextFrame Then
'Identify if there's text in text frame
If Shpe.TextFrame.HasText Then
pptText = Shpe.TextFrame.TextRange
If InStr(1, pptText, "iq_") > 0 Then 'Identify if within text there is "iq_" All IQ's have to be formatted like this "iq_42, iq_43" for now
iq_Array = Split(pptText, ", ") 'Use function below to Set iq_Array to an array of all iq_'s in the text box
xlFindText(iq_Array, xlWB).Copy
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse ' Paste the Array
End If
End If
End If
Next Shpe
Next pptSlide
End Sub
Function xlFindText(iq_Array, xlWB) 'This function works in excel and saves the column values into xlFindText(iq_Array, xlWB) to be pasted as a table into ppt
'SetsxlTextID = to the array of iq_'s
Dim i As Integer
Dim k As Integer
Dim activeWB As Excel.Workbook
Dim size As String
Dim rng As Range
Dim tble As Range
'for loop to go through values stored in array
size = UBound(iq_Array) - LBound(iq_Array)
For i = 0 To size 'loops through array values
For k = 1 To 200 'loops through cloumns
rng = Worksheets("Sheet1").Cells(1, i).Value
If rng = iq_Array(i) Then 'matches column value to iq_Array
Columns(k).Select
tble(i) = Selection.Copy 'saves a copy of the range into tble() array
End If
Next k
Next i
xlFindText(iq_Array, xlWB) = tble()
End Function
There are several problems with your code, I'll go from start to end, but it may well be I'm missing some.
(1)
Set pptSlide = Application.ActiveWindow.View.Slide
is pointless because directly afterwards you overwrite pptSlide with:
For Each pptSlide In pptPres.Slides
xlFindText
(2)
rng = Worksheets("Sheet1").Cells(1, i).Value
If you work with a different Office program than the one where the code runs in (here Excel from PPT), you always must fully qualify your objects. Don't use shortcuts like ActiveSheet without specifying the parent object (Excel application).
So this should be:
xlWB.Worksheets("Sheet1").Cells(1, i).Value
The same applies to Columns(k).
(3)
rng is a Range object. This doesn't go together with a cell value.
Either
Set rng = xlWB.Worksheets("Sheet1").Cells(1, i)
or
Dim varValue As Variant
varValue = xlWB.Worksheets("Sheet1").Cells(1, i).Value
(4)
tble(i) = Selection.Copy
This is not how Range.Copy works, please check the Excel Online Help.
You will have to change the logic of xlFindText - either return a column number from this function and do the Copy + Paste in the main function, or do both in xlFindText (then pass pptSlide as parameter).

Populate word document from excel without deleting bookmarks

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

Inserting text in a embedded Word template, at a bookmark, from excel. "error 13 Type mismatch" error

I am currently working on a project that have one word template embedded in one excel template.
A button in excel was created for opening the embedded word template, exporting the data from excel and puting them into word by using bookmarks in word template. The issue is that word report can be generated only once, because the text will be insert into the original bookmark rather than overwrite the previous data.
I'm trying to export a named field from excel(CoverPageRCA) and copy it into an embedded word template using a bookmark (bkmtable1_1).
I get:
run-time error 13 Type mismatch
that occurs at the following line:
Set bkMark = ActiveDocument.Bookmarks(bookmarkname).Range
I searched the web and spent almost 24 hrs on it. Can anybody please suggest a solution?
Option Explicit
Dim WD As New Word.Application
Dim RCAcell1 As Range
Sub CreateRCAReports1()
Dim wordDoc As Word.Document
Dim oleObj As oleObject
Dim WordApp As Word.Application
WD.Visible = True
Set oleObj = ActiveWorkbook.Sheets("CoverPageRCA").OLEObjects(1)
oleObj.Verb xlVerbPrimary
Set WordApp = oleObj.Object.Application
With WordApp
.Visible = True
.Activate
Set wordDoc = .Documents(1)
End With
'-------------------------------------------------------
ThisWorkbook.Sheets("CoverPageRCA").Activate
ActiveSheet.Range("B2").Select
Set RCAcell1 = ActiveSheet.Range(ActiveCell, ActiveCell.End(xlDown))
'go to each bookmark and type in details
CopyCell1 "bkmtable1_1", 1
Set WD = Nothing
End Sub
'----------------------------------------------------------
Sub CopyCell1(bookmarkname As String, RowOffset As Integer)
Dim bkMark As Range
'clear content on each bookmark and add new bookmarK
Set bkMark = ActiveDocument.Bookmarks(bookmarkname).Range
bkMark.Select
bkMark.Text = "dsfsf"
ActiveDocument.Bookmarks.Add bookmarkname, bkMark
'copy each cell to relevant Word bookmark
WD.Selection.GoTo What:=wdGoToBookmark, Name:=bookmarkname
WD.Selection.TypeText RCAcell1(RowOffset, 1).Value
End Sub
Looking at the code, the issue is on declaration of bkMark:
Dim bkMark As Range
The range object exists on both Excel and Word (different objects), and as the code above runs on excel, it will declare bkMark as an Excel Range object, not a Word Range object.
But the range returned on the line below is a Word range, causing the type mismatch error.:
Set bkMark = ActiveDocument.Bookmarks(bookmarkname).Range
To fix this issue, you must declare bkMark as a Word range,:
Dim bkMark As Word.Range

Loop Copy/pasting data in NamedCells from excel into Word

I am working on Macro that copies data from NamedCells in Excel and places them at specific Bookmarks in a Word template. I am getting a run time error 9 when the code gets to the pasting data at Bookmarks line. Further, some of the data is getting pasted into the template but "Title1" is getting pasted at BookmarkTitle2 location and Title2 is getting pasted at BookmarkTitle3... then the run time error comes up...
Code is below....
Can someone tell me what I am doing wrong?
Sub CopyExcelTitlesToWord()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim BookmarkArray As Variant
Dim Title(1 To 3) As Range
Dim x As Integer
'List the tables/charts from excel you want to Word
Set Title(1) = ThisWorkbook.Worksheets("TopPage").Range("Title1")
Set Title(2) = ThisWorkbook.Worksheets("TopPage").Range("Title2")
Set Title(3) = ThisWorkbook.Worksheets("TopPage").Range("Title3")
'List of corresponding Word Bookmarks to paste the tables/charts to in Word
BookmarkArray = Array("BookmarkTitle1", "BookmarkTitle2", "BookmarkTitle3")
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Open Word template
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
'Open existing template in Word
Set myDoc = WordApp.Documents.Open("C:\Users\xxx\Desktop\TemplateTest1.docx")
'Loop Through and Copy/Paste Multiple Excel NamedCells
For x = LBound(Title) To UBound(Title)
Title(x).Select
Selection.Copy
'Paste Title into MS Word (using inserted Bookmarks -> ctrl+shift+F5). 'Name the Bookmarks so they are in Series so they are easy to loop through.
myDoc.Bookmarks(BookmarkArray(x)).Range.PasteExcelTable False, False, True
Next x
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
BookmarkArray will be a 0 based array (0..2) - see Excel help on the Array function.
I suggest you change
Dim Title(1 To 3) As Range
to
Dim Title(0 To 2) As Range
and change the hard coded indexes accordingly.