Extract Word Table Into Excel VBA - excel

I have a few Word files with the Tables containing Data which I want to export to excel. I've found a script that did it manually. I modified it in the hopes of having it automatically do the same for all files. Each table it finds gets put into a new sheet and then I want it to save with the same File name as the word document. After running the code I get a Compile Error : Type Mismatch which points towards folder = Dir("C:\Users\user\Desktop\folder"). Here's the code :
Option Explicit
Sub AA()
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim file As Word.Document
Dim oTbl As Word.Table
Dim FilePath As String
Dim wbk As Workbook
Dim wsh As Worksheet
Dim folder As Object
' Prompt for document
Application.ScreenUpdating = False
' Create new workbook
Set wbk = Workbooks.Add(Template:=xlWBATWorksheet)
' Get or start Word
Set oWord = GetObject(Class:="Word.Application")
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
'On Error GoTo Err_Handler
' Open document
Set folder = Dir("C:\Users\user\Desktop\folder")
For Each file In folder
If file.GetExtensionName(file.Path) = "docx" Then
FilePath = "C:\Users\user\Desktop\folder\" & file & ".docx"
Debug.Print FilePath
Set file = oWord.Documents.Open(Filename:=FilePath)
' Loop through the tables
For Each oTbl In file.Tables
' Create new sheet
Set wsh = wbk.Worksheets.Add(After:=wbk.Worksheets(wbk.Worksheets.Count))
' Copy/paste the table
oTbl.Range.Copy
wsh.Paste
Next oTbl
' Delete the first sheet
Application.DisplayAlerts = False
wbk.Worksheets(1).Delete
Application.DisplayAlerts = True
wsh.SaveAs Filename:=""
End If
Next
'Exit_Handler:
'On Error Resume Next
' oDoc.Close SaveChanges:=False
'If WordNotOpen Then
' oWord.Quit
' End If
' 'Release object references
' Set oTbl = Nothing
'Set oDoc = Nothing
' Set oWord = Nothing
'Application.ScreenUpdating = True
' Exit Sub
'Err_Handler:
' MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
' Resume Exit_Handler
End Sub

Related

Open Multiple WORD FILES based on a list, perform tasks , save and close

I'd like to open a bunch of word files, from a list of file names in my excel workbook, activate the opened word files, perform a text replacement, and save the changes.
I can't make the liaison between Excel VBA and Word files.
Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String
On Error Resume Next
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx" '(xDPathStr is the path I have defined earlier with all the word files)'
'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate
wrdApp.Visible = True
Modify Word Files From a List in Excel
It is assumed that the file names are in column A. It will open each file and replace all occurrences of one string with another.
The focus here is on how to reference (open) Word, open files, modify them (not so much), close them with saving changes, and finally close Word only if it was initially closed.
Option Explicit
Sub VisitWord()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Late Binding (not recommended at this stage)
' When you get familiar with how it works, switch to Late Binding:
' Dim wdApp As Object
' Dim WordWasClosed As Boolean
' On Error Resume Next ' see if Word is open
' Set wdApp = GetObject(, "Word.Application") ' attempt to create a reference to it
' On Error GoTo 0
' If wdApp Is Nothing Then ' Word is not open
' WordWasClosed = True
' Set wdApp = CreateObject("Word.Application") ' open and create a reference to it
' End If
' wdApp.Visible = True ' default is false; outcomment when done testing
' Dim wdDoc As Object
' ' etc.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Early Binding
' For this to work, in Excel, you need to create a reference to
' Tools > References > Microsoft Word 16.0 Object Library
' Use this to have the Word intellisense work for you.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const WordFolderPath As String = "C:\Test\"
Const FINDSTRING As String = "Old String"
Const REPLACESTRING As String = "New String"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim rg As Range
Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim wdApp As Word.Application
Dim WordWasClosed As Boolean
On Error Resume Next ' see if Word is open
Set wdApp = Word.Application ' attempt to create a reference to it
On Error GoTo 0
If wdApp Is Nothing Then ' Word is not open
WordWasClosed = True
Set wdApp = New Word.Application ' open and create a reference to it
End If
wdApp.Visible = True ' default is false; outcomment when done testing
Dim cell As Range
Dim wdDoc As Word.Document
Dim WordFileName As String
Dim WordFilePath As String
For Each cell In rg.Cells
WordFileName = CStr(cell.Value)
If Len(WordFileName) > 0 Then
WordFilePath = WordFolderPath & WordFileName
If Len(Dir(WordFilePath)) > 0 Then ' file exists
Set wdDoc = wdApp.Documents.Open(WordFilePath)
' Here you do the damage...
wdDoc.Content.Find.Execute _
FindText:=FINDSTRING, _
ReplaceWith:=REPLACESTRING, _
Format:=True, _
Replace:=wdReplaceAll
wdDoc.Close SaveChanges:=True
End If
End If
Next cell
If WordWasClosed Then wdApp.Quit
End Sub
So this is the code i've come up with so far:
Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String
On Error Resume Next
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx" '(xDPathStr is the path I have defined earlier with all the word files)'
'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate
wrdApp.Visible = True
Here is some sample code that I created recently to loop through cells in Excel, which are paths to Word files. Each Word file is opened, scanned for a table (in Word), and copy/paste to Excel. See if you can start with this. Post back if you have additional questions.
Sub LoopThroughAllWordFiles()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim oTbl As Word.Table
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet
Dim cnt As Long
Dim tableCount As Long
Dim lrow As Long
Dim lastrow As Long
Dim file As String
Dim rng As Range, cell As Range
Dim objDoc As Object
Dim objWord As Object
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Set rng = Worksheets("Files").Range("A1:A200")
Worksheets("Word_Tables").Select
filecounter = 1
cnt = 1
Set objWord = CreateObject("Word.Application")
obj.Word.Visible = False
For Each cell In rng.SpecialCells(xlCellTypeVisible)
MyStr = Right(cell, 5)
If MyStr = ".docx" Then
mylength = Len(cell)
pos = InStrRev(cell, "\")
strFolder = Left(cell, pos)
strFile = Right(cell, mylength - pos)
Worksheets("Word_Files").Select
Set objWord = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set sht = ThisWorkbook.Worksheets("Word_Files")
lastrow = Worksheets("Word_Files").UsedRange.Rows.Count + 1
totTbl = objDoc.Tables.Count
Debug.Print totTbl
For Each oTbl In objDoc.Tables
strCellText = oTbl.cell(1, 1).Range.Text
strCellText = LCase(strCellText)
Debug.Print strCellText
If strCellText Like "*data input*" Then
Worksheets("Word_Files").Range("A" & lastrow) = strFolder & strFile
On Error Resume Next
If cnt = 1 Then
lastrow = lastrow
Else
lastrow = ActiveSheet.UsedRange.Rows.Count
End If
oTbl.Range.Copy
Range("B" & lastrow).Select
sht.Paste
cnt = cnt + 1
End If
Next oTbl
End If
filecounter = filecounter + 1
Debug.Print filecounter
objWord.Close
Next cell
objDoc.Quit
Set objDoc = Nothing
objWord.Quit
Set objWord = Nothing
SecondsElapsed = Round(Timer - StartTime, 2)
SecondsFinal = SecondsElapsed / 60
MsgBox ("Code ran in " & SecondsFinal & "minutes.")
End Sub

Extract All Data from Source Folder

I am attempting to extra data from multiple .xlsm in a folder from a specific cell. The idea is to take a folder that has multiple .xlsm files and extract a specific cell into my current workbook.
See code.
Option Explicit
Const FOLDER_PATH = "C:\Users\maxd\OneDrive - Nortek, Inc\Coil Test Data\coils_35_and_36\36\WET\Testing\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
rowTarget = 7
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
'On Error GoTo errHandler
'Application.ScreenUpdating = False
'set up the target worksheet
Set wsTarget = Sheets("Sheet1")
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xlsm*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets("Summary")
'import the data
With wsTarget
.Range("I" & rowTarget).Value = wsSource.Range("B25").Value
'optional source filename in the last column
.Range("N" & rowTarget).Value = sFile
End With
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
Actual Results = it does nothing as if there is not a file in the folder.
Expected Results = It will pull the data from cell B25 and insert it to I7 of my current worksheet.
EDIT: When I F8 through the code, it gets to "Set wsSource = wbSource.Worksheets("Summary")" Then I get a runtime error 91

VBA - PasteSpecial Error and moving to next row in 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.

Trying to copy content from Excel to MS Word

I'm trying to copy a content from excel into a bookmark in MS word. But I'm getting run time error 424. Kindly help me with it. I'm very new to Visual basics and programming as well. I have attached my code.
Thanks
Sub WordDoc()
Dim wrdApp As Object
Dim Number As String
Dim wrdDoc As Object
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("H:\IP Automation\createDoc.docx")
Number = Worksheets("Sheet1").Range("A2")
Call InsBookmark(ID, Number)
End Sub
Sub InsBookmark(strBMName, strVariable)
If strVariable <> "" Then
If ActiveDocument.Bookmarks.Exists(ID) Then
ActiveDocument.Bookmarks(ID).Select
Selection.Delete
Selection.InsertAfter (strVariable)
End If
End If
End Sub
You shouldn't seperate this into two subs, as the word doc will not persist across them so "ActiveDocument" wont work. just copy the code from the second sub into the first and replace ActiveDocument with wrdDoc
This should work for you. Give it a go and see how you get along.
Sub Export_Table_Word()
'Name of the existing Word doc.
Const stWordReport As String = "Final Report.docx"
'Word objects.
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdbmRange As Word.Range
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnReport As Range
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("PwC Contact Information")
Set rnReport = wsSheet.Range("Table1")
'Initialize the Word objets.
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordReport)
Set wdbmRange = wdDoc.Bookmarks("Report").Range
Dim tbl As Table
For Each tbl In wdDoc.Tables
tbl.Delete
Next tbl
'If the macro has been run before, clean up any artifacts before trying to paste the table in again.
On Error Resume Next
With wdDoc.InlineShapes(1)
.Select
.Delete
End With
On Error GoTo 0
'Turn off screen updating.
Application.ScreenUpdating = False
'Copy the report to the clipboard.
rnReport.Copy
'Select the range defined by the "Report" bookmark and paste in the report from clipboard.
With wdbmRange
.Select
.Paste
End With
'Save and close the Word doc.
With wdDoc
.Save
.Close
End With
'Quit Word.
wdApp.Quit
'Null out your variables.
Set wdbmRange = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
'Clear out the clipboard, and turn screen updating back on.
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox "The report has successfully been " & vbNewLine & _
"transferred to " & stWordReport, vbInformation
End Sub

Copy entire worksheet contents into already open Word document

I have two partial working bits of code to put together.
I have a worksheet labeled 'word' that I want to export and save automatically under a variable.
Sub CreateNewWordDoc()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim i As Integer
docname = Worksheets("input").Range("b10").Value
Data1 = Worksheets("word").Range("a1:d103").Value
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\Results\ResultsTemplate.doc")
'******THIS IS TO EDIT THE WORD DOCUMENT******
With Worksheets("word")
CopyRangeToWord wdDoc, .Range("A1:d104")
'******THIS IS THE END TO EDIT THE WORD DOCUMENT*****
If Dir("C:\Results\" & docname & ".doc") <> "" Then
Kill "C:\Results\" & docname & ".doc"
End If
.SaveAs ("C:\Results\" & docname & ".doc")
.Close ' close the document
End With
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
I like this first one the best. It will open my template that has all the official stuff that these generated reports will require (company info etc) and will automatically save and close with the correct file name. However, I cannot find a way to get it to copy all the information from the worksheet 'word' into the text body of the document. It is saving a blank document.
While troubleshooting, I came across this code:
Private Sub CopyRangeToWord(ByRef wdDoc As Word.Document, rng_to_copy As Range, Optional page_break As Boolean = True)
' Will copy the range given into the word document given.
Application.StatusBar = "Copying data from " & rng_to_copy.Parent.Name & "..."
rng_to_copy.Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
Application.CutCopyMode = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
' insert page break after all worksheets except the last one
If page_break Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
End Sub
Sub CopyWorksheetsToWord()
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
docname = Worksheets("input").Range("b10").Value
With Worksheets("word")
CopyRangeToWord wdDoc, .Range("A1:d104")
End With
Set ws = Nothing
Application.StatusBar = "Cleaning up..."
'apply normal view
With wdApp.ActiveWindow
If .View.SplitSpecial = wdPaneNone Then
.ActivePane.View.Type = wdNormalView
Else
.View.Type = wdNormalView
End If
End With
Set wdDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
Application.StatusBar = False
End Sub
which does the exact opposite of the first code: it will open up a new document (not the template), will copy all the data perfectly but will not save or close with correct filenames.
I am guessing that it will be easier to update code section one to copy the worksheet contents, and is what I would prefer.
Private Sub CopyRangeToWord(ByRef wdDoc As Word.Document, rng_to_copy As Range, Optional page_break As Boolean = True)
' Will copy the range given into the word document given.
Application.StatusBar = "Copying data from " & rng_to_copy.Parent.Name & "..."
rng_to_copy.Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
Application.CutCopyMode = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
' insert page break after all worksheets except the last one
If page_break Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
End Sub
Sub CopyWorksheetsToWord()
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
docname = Worksheets("input").Range("b10").Value
With Worksheets("word")
CopyRangeToWord wdDoc, .Range("A1:d104")
With wdDoc
.SaveAs ("C:\Results\" & docname & ".doc")
.Close
End With
End With
End Sub
this works: but does not open from my template. nonetheless - it will create a document from one worksheet and automatically save it to the directory with the filename referenced in a defined cell.

Resources