VBA - PasteSpecial Error and moving to next row in Excel - excel

I am trying to loop through a number of word documents in a folder, and add some information from the word tables to the excel sheet. Right now I have this:
Private Sub Loop_WordToExcel()
Dim WdApp As Object
Dim wddoc As Object
Dim docName As String
Dim strFile As String
Dim directory As String
directory = "c:\path\to\folder"
strFile = Dir(directory & "*.*")
Set WdApp = CreateObject("Word.Application")
Dim rng As Range
Set rng = Application.InputBox(Prompt:="Enter row", Type:=8)
'Do While strFile <> ""
Set wddoc = WdApp.Documents.Open(Filename:=directory & strFile)
rng.Cells(1) = wddoc.Name
'First Name
wddoc.Tables(1).Cell(1, 3).Range.Copy
rng.Cells(2).PasteSpecial (xlPasteValues)
WdApp.ActiveDocument.Close SaveChanges:=False
strFile = Dir
Loop
End Sub
I have two questions.
1. My first issue is a Run-time error '1004': PasteSpecial method of Range class failed
2. At the end of the loop, how to I advance to the next row for the next word document information to be pasted.

Correct syntax while copying from Word is given, May try
Sub Loop_WordToExcel()
Dim WdApp As Word.Application
Dim WdDoc As Document
Dim docName As String
Dim strFile As String
Dim directory As String
Dim Rng As Range
Dim Offst As Long, Txt As String
directory = "C:\users\user\Desktop\Folder1\" ' Change to your path
strFile = Dir(directory & "*.docx") ' docx extension added to prevent attempt to open other type of files
Set Rng = Application.InputBox(Prompt:="Enter row", Type:=8) '
Set WdApp = CreateObject("Word.Application")
WdApp.Visible = True
Do While strFile <> ""
Set WdDoc = WdApp.Documents.Open(Filename:=directory & strFile)
Rng.Offset(Offst, 0).Value = WdDoc.Name
'First Name
WdDoc.Tables(1).Cell(1, 3).Range.Copy 'will raise error if table& corres cell not exists , My use error handrel
Rng.Offset(Offst, 1).Activate
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False 'Assumed want get name in Column B
'is is suggested to use the below two lines instead of paste special above three lines
'Txt = WdDoc.Tables(1).Cell(1, 3).Range.Text 'will raise error if table& corres cell not exists , My use error handrel
'Rng.Offset(Offst, 1).Value = Txt
WdDoc.Close SaveChanges:=False
Offst = Offst + 1
strFile = Dir
Loop
WdApp.Quit
End Sub
It is always preferred to add reference of Microsoft Word Object library.

Related

Mail merge into a Word document generates Error Code 4248

My goal is to use two dropdown menus (DM) within a workbook to open a filled-out document.
The DM 1 is to select which row of data will be merged.
The DM 2 is to select which template is being used.
I have separate code that highlights the selected row and opens the document.
Set doc = appWD.ActiveDocument gives me
error 4248 This command is not available because no document is open.
The template is open when I receive this error.
For Context:
Open_LPA_Template, run by itself, does open the Word document selected from the DM 2.
Select_Parcel, run by itself, does highlight the row of data selected from the DM 1.
Sub Run_Mail_Merge_LPA()
Dim doc As Word.Document
Dim appWD As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim tbl As ListObject
Dim row As ListRow
Dim searchValue As String
Dim searchRange As Range
Dim foundCell As Range
' Get references to the workbook and worksheets
Set wb = ThisWorkbook
Set ws = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
' Create an instance of the Word application
Set appWD = CreateObject("Word.Application")
' Open the Word document that has been selected in DM 2
Open_LPA_Template
' Select_Parcel's CODE: Select the Row of Data from DM 1 for the Mail Merge
ws2.Select
' Select cell D3 in worksheet 2
ws2.Range("D3").Select
' Store the value in D3 of worksheet 2 in a variable
searchValue = ws2.Range("D3").Value
' Set the search range to the entire column A of worksheet 1
ws.Select
Set searchRange = ws.Range("A:A")
' Use the Find method to search for the search value in the search range
Set foundCell = searchRange.Find(searchValue)
If Not foundCell Is Nothing Then
' If a match is found, select the cell
foundCell.Select
ActiveCell.EntireRow.Select
Else
' If no match is found, print a message
Debug.Print "Value not found in column A"
End If
' MAIL MERGE CODE: Set the active document to the Word document that was opened
Set doc = appWD.ActiveDocument
' Perform the mail merge
doc.MailMerge.MainDocumentType = wdFormLetters
doc.MailMerge.OpenDataSource _
Name:=row.Range, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:=""
doc.MailMerge.Execute
End Sub
Sub Open_LPA_Template()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim MainPath As String
Dim MainPath2 As String
Dim MainPath3 As String
Dim MainPath4 As String
Dim MainPath5 As String
Dim MainPath6 As String
Dim Parcel As String
Dim fileName As String
Dim FullPath As String
Dim mWord As Object
Set wb = ThisWorkbook
Set ws = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
Set appWD = CreateObject("Word.Application")
appWD.Visible = True
MainPath = "C:\Users\ME\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath2 = "C:\Users\USER1\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath3 = "C:\Users\USER2\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath4 = "C:\Users\USER3\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath5 = "C:\Users\USER4\Dropbox (ORC)\Desktop\Templates\LPA\"
MainPath6 = "C:\Users\USER5\Dropbox (ORC)\Desktop\Templates\LPA\"
fileName = ws2.Range("E3")
' Check if the file exists at the first path
If Dir(MainPath & fileName & ".docx") <> "" Then
FullPath = MainPath & fileName & ".docx"
ElseIf Dir(MainPath2 & fileName & ".docx") <> "" Then
' If the file does not exist at the first path, check the second path
FullPath = MainPath2 & fileName & ".docx"
ElseIf Dir(MainPath3 & fileName & ".docx") <> "" Then
' If the file does not exist at either of the first two paths, check the third path
FullPath = MainPath3 & fileName & ".docx"
ElseIf Dir(MainPath4 & fileName & ".docx") <> "" Then
' If the file does not exist at any of the first three paths, check the fourth path
FullPath = MainPath4 & fileName & ".docx"
ElseIf Dir(MainPath5 & fileName & ".docx") <> "" Then
' If the file does not exist at any of the first four paths, check the fifth path
FullPath = MainPath5 & fileName & ".docx"
Else
' If the file does not exist at any of the first five paths, use the sixth path
FullPath = MainPath6 & fileName & ".docx"
End If
appWD.Documents.Open (FullPath)
There are six paths because it could be accessed/used by six people who get to the shared Word documents through their own computers.
Since you are creating a new instance of Word via
Set appWD = CreateObject("Word.Application")
That Word instance has no open documents. You need to open the relevant document and address it via code like:
Set doc = appWD.Documents.Open(Filename:="C:\Users\Aaron Bradow\Documents\Mail Merge Document.docx", AddToRecentFiles:=False, ReadOnly:=True)
The problem is that you create two separate instances of Word Application in the code and try to access a Document instance opened in another Word Application instance/process. If you want to use the ActiveDocument property you need to deal with a single Word Application instance in the code. So, you may pass a created Word Application instance as a parameter to the method to open files.
Be aware, the Documents.Open function from the Word object model opens the specified document and adds it to the Documents collection. It also returns a Document object which can be used instead of the ActiveDocument property in the code.
Sub OpenDoc()
Dim doc As Word.Document
Set doc = Documents.Open FileName:="C:\MyFiles\MyDoc.doc"
End Sub

Script to Copy all text from multiple Word Documents into seperate cells in a single Excel Document

I am trying to copy all the text, with formatting intact, from each of multiple Word Documents, and paste the text of each into a new cell in a single Excel Spreadsheet, placing the name of the Word Doc in an adjacent cell.
So the file name of "Document 1" goes in cell A1, and the entire contents of "Document 1" goes in cell A2.
We have several hundred Documents that need to be imported onto pages on our new corporate Intranet, and the migration tool provided only works off data in an Excel workbook.
I've checked out a number of threads, videos, and searches and tried to cobble together a couple of different attempts but neither is working. The first, if it did work, may not handle the File Name copy and it seems to run into issues with selecting the destination cell for the copy.
The second seems to be exactly what I want, but I can;t get the Paste into Excel bit working.
The first runs into an issue when it hits the "Range("LastRow").PasteSpecial xlPasteValues" line, saying the range is invalid (I have defined "LastRow" in the Excel Workbook but it doesn't help) :
Sub Copy_Data_From_Multiple_WordFiles()
Dim FolderName As String
Dim FileName As String
Dim NewWordFile As New Word.Application
Dim NewDoc As New Word.Document
Application.DisplayAlerts = False
'Application.ScreenUpdating = False
FolderName = "C:\Test\"
FileName = Dir(FolderName)
'Loop start
Do While FileName ⋖⋗ ""
Set NewDoc = NewWordFile.documents.Open(FolderName & FileName)
NewDoc.Range(0, NewDoc.Range.End).Copy
Range("LastRow").PasteSpecial xlPasteValues
NewDoc.Close SaveChanges:=wdDoNotSaveChanges
NewWordFile.Quit
FileName = Dir()
Loop
End Sub
NB: LastRow is defined in Excel Name Manager as:=OFFSET(CopyDataFromWord!$A$1,COUNTA(CopyDataFromWord!$A:$A),0,1,1)
I have tried a second set of code I got from a post on here, which should be closer to what I'm seeking, but again, won't quite get there. This one fails with a "Run-Time error '424': Object Required" at the line where it should paste into Excel. It doesn't seem to be recognising the Object "objDoc"?
Sub Excel_Word()
Dim WordApp As Object 'New Word.Application
Dim objDoc As Object ' New Word.Document
Dim Range As Object 'Word.Range
Dim WordDoc As String
Dim sPath As String
Dim i As Long
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
sPath = "C:\Users\jdodd\Documents\Cleaned\"
WordDoc = Dir(sPath & "*.docx")
Do While WordDoc <> ""
Set objDoc = WordApp.Documents.Open(sPath & WordDoc)
objDoc.Range.Copy
i = i + 1
ImportPolicyfromWord.Cells(i, 1).Value = objDoc
ImportPolicyfromWord.Cells(i, 2).Value = objDoc.Range.PasteSpecial
WordDoc = Dir()
Loop
WordApp.Quit
'elimina variabili
'Set WordApp = Nothing
'Set objDoc = Nothing
End Sub
Appreciate any advice or help
Try:
Sub GetDocData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String: strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFile As String, WkSht As Worksheet, r As Long
Set WkSht = ActiveSheet
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
'Disable any alerts in the documents being processed
wdApp.DisplayAlerts = wdAlertsNone
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
.ConvertNumbersToText (wdNumberAllNumbers)
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
.Text = "[^12^13^l]{1,}"
.Replacement.Text = "¶"
.Execute Replace:=wdReplaceAll
.Text = "[^t]"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
r = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
If r > 1 Then r = r + 2
WkSht.Range("A" & r).Value = .Name
.Range.Copy
r = r + 1
WkSht.Paste Destination:=WkSht.Range("A" & r)
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
ErrExit:
wdApp.Quit
WkSht.UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Simply select the folder to process. As coded, the macro places the document name above the contents, which are all pasted into one cell. If you want the document name on the same row, but beside the contents, change:
r = r + 1
WkSht.Paste Destination:=WkSht.Range("A" & r)
to:
WkSht.Paste Destination:=WkSht.Range("B" & r)

How to paste values on every page of word document from Excel VBA?

I have a long list of word-paths and start- and endtags in Excel. I need to open the word document using the path specified in Excel, and paste a start-tag on the beginning of every page, and an end-tag on every end of a page. Every document has three pages.
I'm struggling with Excel VBA and cant seem to get it to work. Can anyone help me?
I need my code to run through the list, opening the file, copy the starttag on the beginning of each page, and the end tag on the end of each page, save and close the document and go on to the next document.
My excel structure
Until now, I managed to open my excel document
Sub startword()
Set WordApp = CreateObject("word.Application")
Path = Range("B2").Value & Range("F5").Value
WordApp.Documents.Open Path
WordApp.Visible = True
End Sub
And I was able to copy and paste values to a NEW document.
Sub copyrange()
'declare word vars
Dim WrdApp As Word.Application
Dim WrdDoc As Word.Document
'Path = Range("B2").Value & Range("F5").Value
'declare excel vars
Dim ExcRng As Range
'create new word instance
Set WrdApp = New Word.Application
WrdApp.Visible = True
WrdApp.Activate
Set WrdDoc = WrdApp.Documents.Add
'create reference to range i want to copy
Set ExcRng = ActiveSheet.Range("B2:E6")
'copy the range and wait for a bit
ExcRng.Copy
Application.Wait Now() + #12:00:01 AM#
'paste the object in word
WrdDoc.Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=True, WordFormatting:=True, RTF:=False
WrdApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
WrdDoc.Paragraphs(1).Range.PasteSpecial Link:=True, DataType:=wdPasteOLEObject
'clear clipboard
Application.CutCopyMode = False
End Sub
The range is totally random
PART TWO OF THE QUESTION
I'm struggling with the next piece of my code. I need to extract the contents between the first start and end tag (with the tag included) and move them to doc 1, same with page 2 to doc2, page 3 to doc 3. So I'll get three documents. doc1 with all the first pages of my documents, doc 2 with all the 2nd pages etc. I've made an attempt to find/select the code, but it selects the first and the last page, not the first one.
This is my current code for opening the word docs one by one:
Sub SelectRangeBetween()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to the correct sheetname
Dim wrdApp As Word.Application
Dim WrdDoc As Word.Document
Set wrdApp = New Word.Application '
wrdApp.Visible = True 'set to false for higher speed
Const StarttagColumn = "C" 'Edit this for the column of the starttag.
Const EndtagColumn = "D" 'Edit this for the column of the endtag.
Const FilelocationColumn = "E" 'Edit this for the column of the Filelocation.
Const startRow As Long = 5 'This is the first row of tags and filenames
'Const endRow As Long = 140 'uncomment if you want a fixed amount of rows (for ranges with empty cells)
Dim endRow As Long 'comment out if const-endrow is used
endRow = ws.Range("B" & Rows.Count).End(xlUp).Row 'comment out if const-endrow is used
Dim i As Long
For i = startRow To endRow
Dim wrdPath As String
wrdPath = ws.Cells(i, FilelocationColumn).Value2 '
If wrdPath <> vbNullString Then '
If Dir(wrdPath) <> vbNullString Then '
Dim startTag As String '
Dim endTag As String '
startTag = ws.Cells(i, StarttagColumn).Value2 '
endTag = ws.Cells(i, EndtagColumn).Value2 '
Set WrdDoc = wrdApp.Documents.Open(wrdPath) '
With wrdApp
'.Documents.Add
' .Visible = True
' Types the text
'.Selection.HomeKey Unit:=wdStory
'.Selection.TypeText Text:="Hello and Goodbye"
' The Real script
'Dim StartWord As String, EndWord As String
'StartWord = "Hello"
'EndWord = "Goodbye"
With .ActiveDocument.Content.Duplicate
.Find.Execute FindText:=startTag & "*" & endTag, MatchWildcards:=False
.MoveStart wdCharacter, Len(StardWord)
.MoveEnd wdCharacter, -Len(EndWord)
.Select ' Or whatever you want to do
End With
End With
With WrdDoc
.Close
End With
End If
End If
Next i
End Sub
Try this version, I suggest you try with a small batch of documents first as the document will be saved immediately after pasting the tag. (comment out the lines if you do not want to save and/or close):
Option Explicit
Private Sub PasteTagsToDocument()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to the correct name
Const startRow As Long = 5
Dim endRow As Long
endRow = ws.Range("B" & Rows.Count).End(xlUp).Row
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = New Word.Application
wrdApp.Visible = True
Dim i As Long
For i = startRow To endRow
Dim wrdPath As String
wrdPath = ws.Cells(i, 2).Value2
If wrdPath <> vbNullString Then
If Dir(wrdPath) <> vbNullString Then
Dim startTag As String
Dim endTag As String
startTag = ws.Cells(i, 3).Value2
endTag = ws.Cells(i, 4).Value2
Set wrdDoc = wrdApp.Documents.Open(wrdPath)
With wrdDoc
.Range(0, 0).InsertBefore startTag & vbNewLine
.GoTo(wdGoToPage, wdGoToAbsolute, 2).InsertBefore endTag & vbNewLine & startTag & vbNewLine
.GoTo(wdGoToPage, wdGoToAbsolute, 3).InsertBefore endTag & vbNewLine & startTag & vbNewLine
.Range.Paragraphs.Last.Range.InsertAfter vbNewLine & endTag
.Save 'Comment out if you do not want to save
.Close 'Comment out if you do not want to close the document
End With
Else
If MsgBox("File don't exist. " & vbNewLine & wrdPath & vbNewLine & "Click Ok to Continue or Cancel to stop the macro.", vbOKCancel) = vbCancel Then Exit For
End If
End If
Next i
Set ws = Nothing
Set wrdDoc = Nothing
wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Complete!"
End Sub

Copy and Paste or append file from excel to word doc

ok, so here we go, I have tried to conquer this on my own for the past two days have have tried a lot of solutions. I am working with data in a Excel Spreadsheet that populates a word file. The specific problem I have is placing a table at the end of the word document. I have tried to create the table, and append a word doc that just has the table in it. nether seems to get done. My latest attempt was to just use sendkeys to copy and paste the table from the open documents.
I am willing to try anything at this point, short of doing it manually as I have to generate thousands of files.
Stripped code is below:
Option Explicit
Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow, DaysSince, FrDays, ToDays As Long
Dim DocLoc, TagName, TemplName, FileName As String
Dim TagValue As String
Dim myData As DataObject
Dim CurDt As Date
Dim LastAppDt As Date
Dim WordDoc As Object
Dim WordTable As Object
Dim WordApp As Object
Dim WordContent As Word.Range
Dim oWorkbookEA As Workbook
Set oWorkbookEA = Workbooks.Open(FileName:="M:\Form.xlsx")
Set myData = New DataObject
Dim oTable As Table
Dim oCell As Cell
Dim oPrevRow As Row, oNewRow As Row
Dim iColumn As Long
Dim myRange As Range
Dim NoCol As Integer
Dim NoRow As Integer
With Sheet1
DocLoc = "M:\WIP_Rev4.docx" 'Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
Set WordTable = WordApp.Documents.Open(FileName:="M:\Table.docx", ReadOnly:=True)
LastRow = .Range("E9999").End(xlUp).Row 'Determine Last Row in Table
For CustRow = 6 To 7 'LastRow
DaysSince = .Range("M" & CustRow).Value
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
'For CustCol = 5 To 13 'Move Through 9 Columns
TagValue = .Cells(CustRow, 2).Value 'Tag Value
With WordDoc.Content.Find
.Text = "$Product$"
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
myData.SetText oWorkbookEA.Sheets("Company Info").Shapes("TextBox 6").TextFrame.Characters.Text
myData.PutInClipboard
With WordDoc.Content.Find
.Text = "$VarS$"
.Replacement.Text = "^c"
.Wrap = wdFindStop
.Execute Replace:=wdReplaceOne 'Find & Replace all instances
End With
myData.SetText oWorkbookEA.Sheets("Company Info").Shapes("TextBox 14").TextFrame.Characters.Text
myData.PutInClipboard
'This table works fine as it is preexisting
Set oTable = WordDoc.Tables(4)
Set oPrevRow = oTable.Rows(oTable.Rows.Count)
oPrevRow.Cells(1).Range.Text = "Ingredient Name"
oPrevRow.Cells(2).Range.Text = "No."
oPrevRow.Cells(3).Range.Text = "Percentage"
oTable.Rows.Add
Set oNewRow = oTable.Rows(oTable.Rows.Count)
oNewRow.Cells(1).Range.Text = "Lidocaine"
oNewRow.Cells(2).Range.Text = ""
oNewRow.Cells(3).Range.Text = Format(.Range("E" & CustRow).Value, "#.#%")
oTable.Rows.Add
Set oNewRow = oTable.Rows(oTable.Rows.Count)
oNewRow.Cells(1).Range.Text = "Glycol"
oNewRow.Cells(2).Range.Text = ""
oNewRow.Cells(3).Range.Text = Format(.Range("F" & CustRow).Value, "#.#%")
oTable.Rows.Add
Set oNewRow = oTable.Rows(oTable.Rows.Count)
oNewRow.Cells(1).Range.Text = "Glycerin"
oNewRow.Cells(2).Range.Text = ""
oNewRow.Cells(3).Range.Text = Format(.Range("G" & CustRow).Value, "#.#%")
'With WordDoc
' .Tables(.Tables.Count).Rows(1).Cells(1).Select
' MsgBox (.Tables.Count)
'End With
With oTable.Borders
.InsideLineStyle = wdLineStyleSingle
'.OutsideLineStyle = wdLineStyleDouble
End With
'The begining of my problems
WordDoc.Selection.Collapse Direction:=wdCollapseEnd
WordTable.Active
WordTable.SendKeys ("^a")
WordTable.SendKeys ("^c")
WordDoc.Active
WordDoc.SendKeys ("^v")
FileName = ThisWorkbook.Path & "\" & .Range("A" & CustRow).Value & "_" & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
.Range("N" & CustRow).Value = TemplName 'Template Name
.Range("O" & CustRow).Value = Now
WordDoc.PrintOut
WordDoc.Close
'Kill (FileName) 'Deletes the PDF or Word that was just created
Next CustRow
WordApp.Quit
End With
End Sub
Table document is Table.docx that I have tried to append to the end. That would be my ideal solution.
Thanks for any help you can give
Here's an example of copying a table from one document and pasting it at the end of another:
Sub Tester()
Dim wd As Word.Application
Dim docTbl As Word.Document, docMain As Word.Document
Dim tbl As Word.Table, objRange As Word.Range
Set wd = GetObject(, "Word.application") 'Word already running with the 2 docs open
Set docMain = wd.Documents("Document1")
Set docTbl = wd.Documents("Document2")
Set tbl = docTbl.Tables(1)
tbl.Range.Copy '<< copy the table
Set objRange = docMain.Content
objRange.Collapse Direction:=0 'wdCollapseEnd
objRange.InsertAfter vbCrLf
objRange.Collapse Direction:=0
objRange.Paste '<< paste the table
End Sub
FYI I find the dataobject.putinclipboard approach pretty unreliable in later versions of Excel, so I'd avoid that if you can.

Copy data from several Word documents to one Excel workbook using Word VBA

I have about 100 Word documents and from each I want to copy data and paste it all in one Excel workbook.
I came up with this code which opens one Word document, copies data, pastes it to Excel and closes the Word document:
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
Dim wrdDoc As Object
Documents.Open ("D:\ekr5_i.doc")
TgtFile = "result.xlsx"
Tgt = "D:\" & TgtFile
'finds the text string of Lgth lenght
txt = "thetext"
Lgth = 85
Strt = Len(txt)
'Return data to array
With Selection
.HomeKey unit:=wdStory
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.Workbooks.Open(Tgt)
Set mySh = myWB.Sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.Transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
I need to loop through all the documents in the folder.
I have implemented the same with Excel workbooks, but I don't know how for Word documents.
Here is the code for Excel workbooks:
Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFolder
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)
With oFldialog
If .Show = -1 Then
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
sFolderName = .SelectedItems(1)
End If
End With
Set oFolder = FSO.GetFolder(sFolderName)
Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook
For Each oFile In oFolder.Files
Workbooks(Pivot).Activate
x = Workbooks(Pivot).Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks.Open Filename:=oFile: sSourceName = ActiveWorkbook.Name
Workbooks(sSourceName).Activate
Workbooks(sSourceName).Sheets(1).[A80:Q94].copy
Workbooks(Pivot).Activate
Workbooks(Pivot).Sheets(1).Cells(x + 1, 1).PasteSpecial xlPasteAll
Workbooks(sSourceName).Close False
Next
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There are so, so, so many things you can do between Excel & Word. I'm not sure I totally understand your question. The script below may help you; it has definitely served me well over time. If you need something different, please describe your issue more, to better clarify the issue you are facing.
Sub OpenAndReadWordDoc()
Rows("2:1000000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
' assumes that the previous procedure has been executed
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim blnStart As Boolean
Dim r As Long
Dim sFolder As String
Dim strFilePattern As String
Dim strFileName As String
Dim sFileName As String
Dim ws As Worksheet
Dim c As Long
Dim n As Long
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err Then
Set oWordApp = CreateObject("Word.Application")
' We started Word for this macro
blnStart = True
End If
On Error GoTo ErrHandler
Set ws = ActiveSheet
r = 1 ' startrow for the copied text from the Word document
' Last column
n = ws.Range("A1").End(xlToRight).Column
sFolder = "C:\Users\Excel\Desktop\Coding\Microsoft Excel\PWC\Resumes\"
'~~> This is the extension you want to go in for
strFilePattern = "*.doc*"
'~~> Loop through the folder to get the word files
strFileName = Dir(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'~~> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
' Increase row number
r = r + 1
' Enter file name in column A
ws.Cells(r, 1).Value = sFileName
ActiveCell.Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("A" & r), Address:=sFileName, _
SubAddress:="A" & r, TextToDisplay:=sFileName
' Loop through the columns
For c = 2 To n
If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
MatchWholeWord:=True, MatchCase:=False) Then
' If text found, enter Yes in column number c
ws.Cells(r, c).Value = "Yes"
End If
Next c
oWordDoc.Close SaveChanges:=False
'~~> Find next file
strFileName = Dir
Loop
ExitHandler:
On Error Resume Next
' close the Word application
Set oWordDoc = Nothing
If blnStart Then
' We started Word, so we close it
oWordApp.Quit
End If
Set oWordApp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Function GetDirectory(path)
GetDirectory = Left(path, InStrRev(path, "\"))
End Function
In this scenario, whatever you put in the headers of B1:K1 (or more to the right) is searched for, each word document in a folder is opened, scanned, and if the string in B1:K1 is found, an 'x' is placed in the same x-y coordinate.
Again, if this doesn't help, please describe your issue better, and I'll post back with alternative solutions. Thanks!!

Resources