I have a function to create a table in my Word document.
Running first Main in WordManager assigns objWord and objDoc. Running FnAddTableToWordDocument in WordFormating works on the first run but fails every time on the second run.
The error I get is the following:
Run-time error 6028
The range cannot be deleted
On line:
objDoc.Tables.Add objRange, intNoOfRows, intNoOfColumns
Two Modules:
Module #1 - WordManager:
Module WordManager
Public objWord As Word.Application
Public objDoc As Word.Document
Sub Main() ' This is to be replaced by a call from the actual CA tool.
Call initWordManager("[string path]", "test2.doc")
End Sub
Sub initWordManager(Path, Name)
sFilePath = Path
sFileName = Name
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add
End Sub
Module #2 - WordFormating:
Function FnAddTableToWordDocument()
Dim intNoOfRows
Dim intNoOfColumns
Dim objRange
Dim objTable
intNoOfRows = 5
intNoOfColumns = 3
objWord.Visible = True
Set objRange = objDoc.Range
objDoc.Tables.Add objRange, intNoOfRows, intNoOfColumns
Set objTable = objDoc.Tables(1)
objTable.Borders.Enable = True
For i = 1 To intNoOfRows
For j = 1 To intNoOfColumns
objTable.Cell(i, j).Range.Text = "Sumit_" & i & j
Next
Next
End Function
Setting a more specific range solved the issue.
Set objRange = objDoc.Range(Start:=0, End:=0)
Does not give multiple tables but at least it does not cause an error.
Related
I am trying to paste only from the non empty rows. The error is in line 6. If someone could help me I would really appreciate it because I am stucked with this and I don't kow how to fix it.
Public Sub read_truefalse()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim path As String
path = Sheet5.Cells(3, 1).Value
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open(path, ReadOnly:=True)
Dim i As Long
i = 0
Dim wPara As Word.Paragraph
Dim last As Integer
...
Sheet 7.Activate
1 For Each wPara In wDoc.Paragraphs
2 If wPara.Range.Words.Count > 1 Then
3 last = wPara.Range.Words.Count
4 wPara.Range.Copy
5 Sheet7.Range("A1").Offset(i, 0).Activate
6 Sheet7.Paste
7 i = i + 1
...
Try this:
Public Sub read_truefalse()
Dim wApp As Word.Application
Dim wDoc As Word.Document, wPara As Word.Paragraph
Dim path As String
Dim i As Long, last As Long
path = Sheet5.Cells(3, 1).Value
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open(path, ReadOnly:=True)
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
i = i + 1
last = wPara.Range.Words.Count '??
wPara.Range.Copy
With Sheet7
.Paste Destination:=.Cells(i, "A") 'no need to select to paste
End With
End If
Next wPara
'clean up...
wDoc.Close False
wApp.Quit
End Sub
This script worked perfectly... until it didn't. I have an Excel workbook in the same folder as multiple copies of a Word form. The macro should pull the data from each form and copy it to a row in the workbook. I now get either "OLE Excel is waiting on another application" errors or Runtime 438 errors. The macro I use is as follows:
Sub GetFormData()
Application.ScreenUpdating = False
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim CCtrl As Word.ContentControl
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet, i As Long, j As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.docm", vbNormal)
While strFile <> ""
i = i + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 0
For Each CCtrl In .ContentControls
j = j + 1
WkSht.Cells(i, j).FormulaLocal = CCtrl.Range.Text
Next
End With
wdDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
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
The issue appears to start at "Set wdDoc = wdApp..."
I am a bit of a noob at this. As such, I appreciate your help.
Matt.
I see two possible issues, the first one is almost certainly causing the error; the second could cause this error (but probably not with VBA):
You declare and instantiate the Word application in the same line:
Dim wdApp As New Word.Application
You shouldn't do this. Instead:
Dim wdApp As Word.Application
Set wdApp = New Word.Application
I don't remember the exact details about the "why", but it's something to do with the Word.Application object being created immediately, and at a level where you can no longer control it using Set wdApp = Nothing.
Correctly, all objects of the "outside" application should be released, in reverse order of their creation. You've declared an object of the type Word.ContentControl, but don't release it:
Set Set CCtrl = Nothing : Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
I'm playing around with this code snippet, which I found on SO.
Sub Test()
Dim objWord As Object
Dim ws As Worksheet
Set ws1 = ThisWorkbook.Sheets("Contact Information1")
Set ws2 = ThisWorkbook.Sheets("Contact Information2")
'Set ws3 = ThisWorkbook.Sheets("Contact Information3")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\Users\rshuell001\Desktop\Final Report.docx" ' change as required
With objWord.ActiveDocument
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
.Bookmarks("BkMark2").Range.Text = ws2.Range("A1:F8").Value
'.Bookmarks("Report3").Range.Text = ws3.Range("A1:F80").Value
End With
Set objWord = Nothing
End Sub
When I look at it, it makes sense. When I run the script, I get an error on this line:
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
The error message is:
Run-type error 13
Type mismatch
1) I'm not sure '.Bookmarks("BkMark1").Range.Text' will do what I want. I think it's more of a standard copy/paste.
2) I want to make sure the table fits in the Word document, so I'm going to need something like the line below, to get it to do what I want.
wd.Tables(1).AutoFitBehavior wdAutoFitWindow
Any ideas on how to make this work?
Thanks!
I came up with the script below. It does what I want.
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 wdbmRange1 As Word.Range
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet1 As Worksheet
Dim rnReport1 As Range
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set WDApp = New Word.Application
'Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordReport)
Set WDDoc = WDApp.Documents.Open("C:\Users\rshuell001\Desktop\Final Report.docx")
'Delete old fields and prepare to replace with new
Dim doc As Document
Dim fld As Field
Set doc = WDDoc
For Each fld In doc.Fields
fld.Select
If fld.Type = 88 Then
fld.Delete
End If
Next
Set wsSheet = wbBook.Worksheets("Contact Information1")
Set rnReport = wsSheet.Range("BkMark1")
Set wdbmRange = WDDoc.Bookmarks("BkMark1").Range
'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
WDDoc.Tables(1).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information2")
Set rnReport = wsSheet.Range("BkMark2")
Set wdbmRange = WDDoc.Bookmarks("BkMark2").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(2).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information3")
Set rnReport = wsSheet.Range("BkMark3")
Set wdbmRange = WDDoc.Bookmarks("BkMark3").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(3).AutoFitBehavior wdAutoFitWindow
'Save and close the Word doc.
With WDDoc
.Save
.Close
End With
'Quit Word.
WDApp.Quit
'Null out your variables.
Set fld = Nothing
Set doc = Nothing
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
I am trying to use Visual Basic so that I can populate word templates with data from excel. I have a macro that fills in fields in a Word document table from a table in Microsoft Excel. So far, if the excel table is smaller than the word table, the message "Error! No document variable supplied" prints in the word table and I delete that field using the macro (below). BUT, I also want to delete the entire rows in the Word table where this error occurs. Can you help me figure out how to do this?
Sub Rectangle_Click()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim ws As Worksheet
Dim oHeader As Word.HeaderFooter
Dim oSection As Word.Section
Dim oFld As Word.Field
Dim flds As Word.Fields
Dim fld As Word.Field
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Activate
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then Set wrdApp = CreateObject("Word.Application")
On Error GoTo 0
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Add(Template:="C:\Documents\mytemplate.dotm")
With wrdDoc
.Variables("foo1").Value = Range("A5").Value
.Variables("foo2").Value = Range("A6").Value
.Variables("foo3").Value = Range("A7").Value
.Variables("bar1").Value = Range("B5").Value
.Variables("bar2").Value = Range("B6").Value
.Variables("bar3").Value = Range("B7").Value
.Range.Fields.Update
End With
wrdDoc.Range.Fields.Update
Set flds = ActiveDocument.Fields
For Each fld In flds
If fld.Type = wdFieldDocVariable Then
If fld.Result = "Error! No document variable supplied." Then
Debug.Print fld.Code
'ALSO DELETE THE ROW WHERE THIS EMPTY FIELD WAS FOUND!!'
fld.Delete
End If
End If
Next
Set wrdDoc = Nothing
Set wrdApp = Nothing
Application.CutCopyMode = False
End Sub
How can I get rid of rows (or cells) where "no document variable supplied" occurs?
If you want to delete the whole row of table where your current selection is then use:
Word.Selection.Rows.Delete
Hey everyone I found this awesome code that helped me get the loop I needed but I am trying to alter this to extract all the data from the word tables not just one row of the tables.. Any help would be great. I know it going to be a simple fix just haven't been able to get any to work on my own. Thanks
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`
Sub wordScrape()
Dim wd As New Word.Application
Dim wdDoc As Word.Document
Dim tbl As Word.Table
Dim sh1 As Worksheet
Dim x As Integer
Dim y As Integer
Dim s As String
Dim r As Range
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set r = sh1.Range("a1")
s = Dir(FolderName & "\*.doc*")
Do While s <> ""
If InStr(wd, "~") = 0 Then
Set wdDoc = wd.Documents.Open(FolderName & "\" & s, False, True, False)
For Each tbl In wdDoc.Tables
For x = 1 To t.Rows.Count
r = wdDoc.Name
For y = 1 To t.Columns.Count
r.Offset(0, y) = Application.WorksheetFunction.Clean(t.Cell(Row:=x, Column:=y).Range)
Next y
Set r = r.Offset(1, 0)
Next x
Next tbl
wdDoc.Close False
End If
s = Dir()
Loop
End Sub
Now, this is off the top of my head, it assumes a reference to word is set (tools,references in the VBE) and it crucially assumes that every table has no merged cells - if they do it will break. But it gets you started