Private Sub Submit_Click()
'----------The Script below writes values to Word Doc ----------------------------------------
Dim wApp As Object
Dim wDoc As Object
'We need to continue through errors since if Word isn't
'open the GetObject line will give an error
'On Error Resume Next
Set wApp = GetObject(, "Word.Application")
'We've tried to get Word but if it's nothing then it isn't open
If wApp Is Nothing Then
Set wApp = CreateObject("Word.Application")
End If
'It's good practice to reset error warnings
On Error GoTo 0
'Open your document and ensure its visible and activate after opening
Set wDoc = wApp.Documents.Open(Filename:="C:\Documents\example.docx ", ReadOnly:=False)
With wDoc
.Bookmarks("bookmark1").Range.Text = Me.TextBox1.Value 'how do I also insert the TextBox1.Value to the next empty row in worksheet?
'so far I got this to do it but everytime i click submit it puts it in the same cell instead of the next row
Sheet6.Range("H2").Value = Me.TextBox6.Value
End With
wApp.Visible = True
'set default file name and file path
ProposedFileName = Format(Now(), "DDMMMYYYY") & TextBox1.Value & "-" & ".doc"
ProposedFilePath = "C:\Documents\"
With wApp.FileDialog(msoFileDialogSaveAs)
wDoc.SaveAs2 ProposedFilePath & ProposedFileName, _
FilterIndex = 1, _
FileFormat:=wdFormatDocument
End With
End Sub
Hi all,
The code above is just a part of my script which works fine when the userform textbox value gets inserted to bookmark1 in word doc, but how do I also insert this textbox value to worksheet row for example goes under column header "name"?
Thank you.
I have finally managed to solve it by adding the code
Dim LastRow As Long, ws As Worksheet
Set ws = Sheets(2)
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 'Finds the last blank row
ws.Range("A" & LastRow).Value = TextBox1.Value 'Adds the TextBox1 into Col A & Last Blank Row
Related
I am trying to select ranges from an excel workbook to paste at certain locations in a word document template. I have a table in sheet 3 that has a column with Table1 then the cell next to it is empty. Table1 is written in the word document in the place where I want table one to be pasted. I have the following code to try and select the range of each table based on the header number of the table and loop through all tables. Any help would be appreciated, If you have another method let me know. This is the code I have so far.
Sub Auto()
Dim cell As Range
Dim rng As Range
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim wdDoc2 As Word.Document
Dim FilePath As String
Dim FilePath2 As String
Dim ending As String
Dim rngPara As Range
Dim Prompt As String
Dim Filesave As String
Dim FileSave2 As String
Dim CL As Range
Dim rngg As Range
'On Error GoTo ErrorHandler
'FilePath = ThisWorkbook.Path
'FilePath2 = Left(FilePath, InStr(FilePath, "\Calculations") - 1)
'FileName2 = "Disclosures Temps.docx"
'StrDoc = FilePath2 & "\Input" & "\" & FileName2
'Set wdDoc2 = wdApp.Documents.Open(StrDoc)
Set rngPara = Sheet3.Range("A1:Z1058").Find("Table Key")
If rngPara Is Nothing Then
MsgBox "Table Key column was not found."
GoTo ErrorHandler
End If
Set rng = Sheet3.Range(rngPara, rngPara.End(xlDown))
For Each cell In rng
If cell.Value = "" Then Exit For
For i = 6 To Sheet3.Range("TableNumber").Value
rownum = WorksheetFunction.Match(Format(i, "0"), Range("A:A"), 0)
rownend = WorksheetFunction.Match(Format(i + 1, "0"), Range("A:A"), 0) - 1
rowww = rownum & ":" & rownum
coll = WorksheetFunction.Index(Sheet1.Range("4:4") = "", 0)
colnumber = WorksheetFunction.Match(True, WorksheetFunction.Index(Range("4:4") = "", 0), 0) - 1
ColLetter = Split(Cells(1, colnumber).Address, "$")(1)
rng.Cells.Offset(0, 1).Value = "A" & rownum & ":" & ColLetter & rowend
Next i
Next
You can access named ranges/tables in Excel VBA through the worksheets ListObjects collection. Knowing that we can loop through the worksheets and then through the ListObjects property to access each table. From there you can search for a key if you like or you can go off the name of the table instead which might be easier and paste where you want in the Word document.
The example below is meant to be run from the Word document directly but you can adapt to run from Excel instead. The example opens the Excel workbook containing the tables, loops through the worksheets and their ListObjects collection, copies the tables, and pastes them to the bottom of the Word document.
Sub InsertTablesFromExcelToEndOfDocument()
Const strWorkbookPath As String = "C:\temp\search.xlsm" 'the name and path of the workbook
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(FileName:=strWorkbookPath)
xlApp.Visible = False
For Each xlSheet In xlBook.Worksheets()
For Each xlTable In xlSheet.ListObjects 'Use ListObjects to access Named Table Ranges
Debug.Print "Worksheet Name: " & xlSheet.Name
With xlTable
Debug.Print "-- Table Name: " & .Name
Debug.Print "-- Table Range: " & .Range.Address
Debug.Print ""
.Range.Copy
With ThisDocument.Content
.InsertParagraphAfter
.Paragraphs.Last.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
End With
End With
Next xlTable
Next xlSheet
Cleanup:
xlApp.Quit
End Sub
Update
The following update is an adjustment to the previous code with some code to search for the table name in the document and paste the corresponding tables there. I went with surrounding the table names with angle brackets just so that it is less likely to mistake real content for the table placeholders
Sub InsertTablesFromExcelAtPlaceholders()
Const strWorkbookPath As String = "C:\temp\search.xlsm" 'the name and path of the workbook
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
Dim myRange As Range
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(FileName:=strWorkbookPath)
xlApp.Visible = False
For Each xlSheet In xlBook.Worksheets()
For Each xlTable In xlSheet.ListObjects 'Use ListObjects to access Named Table Ranges
'Debug.Print "Worksheet Name: " & xlSheet.Name
Debug.Print "-- Table Name: " & xlTable.Name
'Debug.Print "-- Table Range: " & xlTable.Range.Address
'Debug.Print ""
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="<" & xlTable.Name & ">"
While myRange.Find.Found = True
xlTable.Range.Copy
myRange.Paste
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="<" & xlTable.Name & ">", Forward:=True
Wend
Next xlTable
Next xlSheet
Cleanup:
xlApp.Quit
End Sub
Can I alter the code to work for a certain range that is not necessarily a table. like I want to specify the range like from the header to the last empty row and from column A to the last empty column. Is this possible?
Sure this is possible, but I would recommend converting the range to a named table instead if possible which would greatly simplify things. You're either defining this range there in the Excel workbook or directly in the code. It's easier to manage if you can define the range and the placeholder outside of the code rather than dipping into the code every time you need to define a new table range.
But back to your question, I think it would be easier to answer if I understood this "Table Key" idea you have. In the code you are looking through what looks like the whole spreadsheet for this "table key" however in your post you say "I have a table in sheet 3 that has a column with Table1 then the cell next to it is empty.". So is your table key actually the first cell in this column you mention? It would be helpful to see an example of the table and this key. If you're interested you can edit your post and add a screenshot or two.
I have a table in excel which has the data I would like to transfer to a word document. Based on which column the values are in I am trying to put the data into a different tabbed order (Ex: List Level 1 is initial list, List Level 2 is pressing tab once in list).
I am trying to do this by recognizing a cell on a previous sheet and the code I have so far works to get the word document open but in order to actually bring in the data I can't seem to figure it out.
My current code is show below (I have the word document "Template.docx" in the same folder:
Private Sub CreateList()
Dim WRD As Object, DOC As Object
On Error Resume Next
Set WRD = CreateObject("Word.Application")
If Err.Number <> 0 Then
Set WRD = CreateObject("Word.Application")
End If
On Error GoTo 0
Set DOC = WRD.Documents.Open(ThisWorkbook.Path &
"\Template.docx", ReadOnly:=True)
WRD.Visible = True
If Sheet1.Range("A1").Value = "Package 1" Then
With DOC
' INSERT DATA FROM EXCEL INTO A TAB DELIMITED LIST
End With
End If
Set WRD = Nothing
Set DOC = Nothing
End Sub
You refer to a tab-delimited list in Word, but your pic depicts something that would ordinarily be dealt with as paragraph headings in Word.
Assuming you really want headings and that your Word document employs Word's Heading Styles with multi-level list-numbering correctly, you could use something like:
Sub CreateList()
'Note: A reference to the Word library must be set, via Tools|References
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim xlSht As Worksheet, sPath As String, LRow As Long, LCol As Long, r As Long, c As Long
sPath = ActiveWorkbook.Path: Set xlSht = ActiveSheet
With xlSht.Cells.SpecialCells(xlCellTypeLastCell)
LRow = .Row: LCol = .Column: If LCol > 9 Then LCol = 9
End With
With wdApp
.Visible = False
Set wdDoc = .Documents.Open(Filename:=sPath & "\Template.docx", AddToRecentFiles:=False, ReadOnly:=True, Visible:=True)
With wdDoc
For r = 2 To LRow
For c = 1 To LCol
If xlSht.Cells(r, c).Value <> "-" Then
.Characters.Last.InsertBefore xlSht.Cells(r, c).Value & vbCr & vbCr
.Characters.Last.Previous.Previous.Style = "Heading " & c
End If
Next
Next
End With
.Visible = True
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlSht = Nothing
End Sub
If you're wedded to using list-level numbering, you could replace the:
If xlSht.Cells(r, c).Value <> "-" Then
...
End If
code block with something like:
If xlSht.Cells(r, c).Value <> "-" Then
.Characters.Last.InsertBefore xlSht.Cells(r, c).Value & vbCr & vbCr
With .Paragraphs(.Paragraphs.Count - 2).Range.ListFormat
.ApplyListTemplateWithLevel ListTemplate:=ListGalleries(wdOutlineNumberGallery).ListTemplates(2), _
ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:=wdWord9ListBehavior
.ListLevelNumber = c
End With
End If
and insert:
For c = 1 To LCol ' or 9 for all possible levels
.ListTemplates(2).ListLevels(c).TextPosition = InchesToPoints(c * 0.5 - 0.5)
.ListTemplates(2).ListLevels(c).ResetOnHigher = True
Next
after the existing final 'Next'.
If the above doesn't provide the list numbering format you want, you will need to choose the appropriate ListGallery (from wdBulletGallery, wdNumberGallery, or wdOutlineNumberGallery) and the and ListTemplate number.
Problem:
I would like to create letters using 2 different letter templates based on a cell value in a column in Excel.
My Question is an extension to the following question:
VBA Automated Mailmerge using 2 templates based on cell value
Example:
In the example below, the value in column C should dictate which letter template will be used for each row. (If cell value is YES use letter template "Yes.docx" otherwise use letter template "No.docx")
Solution proposed by #user3598756 (modified to the above example):
Option Explicit
Sub CommandButton2_Click()
Dim wordApp As Object
Set wordApp = GetWordObject '<--| get a Word object
If wordApp Is Nothing Then Exit Sub '<--| if no Word Object has been gotten then exit sub
With ThisWorkbook.Sheets("Sheet1") '<--| reference your letter worksheet
With Application.Intersect(.UsedRange, Range("A1:C1").EntireColumn) '<--| reference your data range as that in referenced worksheet columns D:H used range
CreateWordDocuments .Cells, "YES", wordApp, "C:\Users\camil\Desktop\YES.docx" '<--| process "YES" documents
CreateWordDocuments .Cells, "NO", wordApp, "C:\Users\camil\Desktop\NO.docx" '<--| process "NO" documents
End With
.AutoFilterMode = False '<--| show all rows back and remove autofilter
End With
'"dispose" Word
wordApp.Quit True '<--| quit Word and save changes to open documents
Set wordApp = Nothing
End Sub
Sub CreateWordDocuments(dataRng As Range, criteria As String, wordApp As Object, templateDocPath As String)
Dim cell As Range
With dataRng '<--| reference data range
.AutoFilter Field:=3, Criteria1:=criteria '<--| filter it on its column 3 with given criteria
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any cell has been filtered
For Each cell In .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) '<--| loop through filtered cells
wordApp.Documents.Add templateDocPath '<-- open the passed Word template
wordApp.Run "Module1.SaveIndividualWordFiles" '<--| run your macro
Next cell
End If
End With
End Sub
Function GetWordObject() As Object
Dim wordApp As Object
On Error Resume Next
Set wordApp = GetObject(, "Word.Application") '<--| try getting a running Word application
On Error GoTo 0
If wordApp Is Nothing Then Set wordApp = CreateObject("Word.Application") '<--| if no running instance of Word has been found then open a new one
Set GetWordObject = wordApp '<--| return the set Word application
wordApp.Visible = False
End Function
Request:
Unfortunately, the original poster of the question didn't share his "SaveIndividualWordFiles" macro.
I tried to fill in the gap with parts of the VBA I usually use to mailmerge from Word, when I only have one letter template. (Seen below)
However I can't fit the pieces together.
Sub Merge_To_Individual_Files()
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & Application.PathSeparator
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Col A")) = "" Then Exit For
StrName = .DataFields("Col A") & " " & .DataFields("Col C")
End With
.Execute Pause:=False
If Err.Number = 5631 Then
Err.Clear
GoTo NextRecord
End If
End With
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
.SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
Next i
End With
Application.ScreenUpdating = False
End Sub
Any help is appreciated.
In another post I finally got to choose a table from a Word file and get it to an Excel file. I have the following code in Word VBA:
Dim wrdTbl As Table
Dim RowCount As Long, ColCount As Long, i As Long, j As Long
'Excel Objects
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
'Set your table
Set wrdTbl = ActiveDocument.Tables(InputBox("Table # to copy? There are " & ActiveDocument.Tables.Count & " tables to choose from."))
'If ActiveDocument.Tables.Count = 0 Then MsgBox "There are no tables in word document"
'Exit Sub
'Get the word table Row and Column counts
ColCount = wrdTbl.Columns.Count
RowCount = wrdTbl.Rows.Count
'Create a new Excel Application
Set oXLApp = CreateObject("Excel.Application")
'Hide Excel
oXLApp.Visible = False
'Open the relevant Excel file
Set oXLwb = oXLApp.Workbooks.Open("C:\Users\" & Environ("Username") & "\Desktop\ExcelEx.xlsx")
'Work with Sheet1. Change as applicable
Set oXLws = oXLwb.Sheets(1)
'Loop through each row of the table
For i = 1 To RowCount
'Loop through each cell of the row
For j = 1 To ColCount
'This gives you the cell contents
wrdTbl.Cell(i, j).Range.Copy
With oXLws
.Range("A1").Activate
.Cells(i, j).Select
.PasteSpecial (wdPasteText)
.Range("A1").CurrentRegion.Style = "Normal"
End With
Next
Next
'Close and save Excel file
oXLwb.Close savechanges:=True
'Cleanup (VERY IMPORTANT)
Set oXLws = Nothing
Set oXLwb = Nothing
oXLApp.Quit
Set oXLApp = Nothing
MsgBox "Done"
End Sub
My problem is that if I have a table with merged cells it throws the error: "5941" requested member of the collection does not exist on the line:
wrdTbl.Cell(i, j).Range.Copy
How can I get the code to copy merged cells too?
Another problem it is when I have a cell with multiple lines because in the Excel file it copies these cell lines in different cells in Excel. How can I solve this too?
Thank you so much for your answers!
You need to loop through the cells individually, rather than by rows and columns. For example:
Dim wrdTbl As Table, c As Long
'Excel Objects
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
'Set your table
With ActiveDocument
If ActiveDocument.Tables.Count = 0 Then MsgBox "There are no tables in word document"
Exit Sub
Else
Set wrdTbl = .Tables(InputBox("Table # to copy? There are " & .Tables.Count & " tables to choose from."))
End If
End With
'Create a new Excel Application
Set oXLApp = CreateObject("Excel.Application")
With oXLApp
'Hide Excel
.Visible = False
'Open the relevant Excel file
Set oXLwb = oXLApp.Workbooks.Open("C:\Users\" & Environ("Username") & "\Desktop\ExcelEx.xlsx")
End With
'Loop through each row of the table
With wrdTbl.Range
For c = 1 To .Cells.Count
With .Cells(c)
'Work with Sheet1. Change as applicable
oXLwb.Sheets(1).Cells(.RowIndex, .ColumnIndex).Value = Split(.Range.Text, vbCr)(0)
End With
Next
End With
'Close and save Excel file
oXLwb.Close True
'Cleanup (VERY IMPORTANT)
oXLApp.Quit
Set oXLwb = Nothing: Set oXLApp = Nothing
MsgBox "Done"
If you want to replicate the Word table in Excel, replace:
'Loop through each row of the table
With wrdTbl.Range
For c = 1 To .Cells.Count
With .Cells(c)
'Work with Sheet1. Change as applicable
oXLwb.Sheets(1).Cells(.RowIndex, .ColumnIndex).Value = Split(.Range.Text, vbCr)(0)
End With
Next
End With
with:
wrdTbl.Range.Copy
With oXLwb.Sheets(1)
.Paste .Range("A1")
End With
My issue is after I have imported a table from Microsoft Word into Excel by creating an OLEObject, it won't let me copy and paste the table into excel. It continually keeps pasting whatever was last copied on my clipboard into the first cell. Currently my code asks the user for the file name, opens that file as an OLEObject in the active excel sheet, and then pastes the incorrect information into cell A1. It's not copying and pasting what's inside the Word OLEObject.
Sub Macro1()
Dim FName As String, FD As FileDialog
Dim ExR As Range
Set FD = Application.FileDialog(msoFileDialogOpen)
FD.Show
If FD.SelectedItems.Count <> 0 Then
FName = FD.SelectedItems(1)
Else
Exit Sub
End If
ActiveSheet.OLEObjects.Add(fileName:=FName, Link:=False, DisplayAsIcon:=False).Select
Selection.Verb Verb:=xlPrimary
Range("A1").Select
ActiveSheet.Paste
End Sub
Thank you!
From Word to Excel, should be something like this.
Sub ImportFromWord()
'Activate Word Object Library
'Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Set WordApp = CreateObject("word.application") ' Open Word session
WordApp.Visible = False 'keep word invisible
Set WordDoc = WordApp.Documents.Open("C:\Users\your_path_here_\WordFile.docx") ' open Word file
'copy third row of first Word table
WordDoc.Tables(1).Rows(3).Range.Copy
'paste in Excel
Range("A1").PasteSpecial xlPasteValues
WordDoc.Close 'close Word doc
WordApp.Quit ' close Word
End Sub
Or this.
Sub GetTables()
FName = Application _
.GetOpenFilename("Word Files (*.doc), *.doc")
Set WordObject = GetObject(FName)
First = True
RowCount = 2
For Each Tble In WordObject.tables
For i = 1 To 22
If First = True Then
Data = Tble.Rows(i).Cells(1).Range
'Remove cell markers
Cells(1, i) = Left(Data, Len(Data) - 2)
End If
Data = Tble.Rows(i).Cells(2).Range.Text
'Remove cell markers
Cells(RowCount, i) = Left(Data, Len(Data) - 2)
Next i
RowCount = RowCount + 1
First = False
Next Tble
WordObject.Close savechanges = False
End Sub
Using the code from the link How to preserve source formatting while copying data from word table to excel sheet using VB macro? , I've only been able to get the code to work when the macro pastes my Word table in a whole new separate workbook. When clicking a command button that's within the excel workbook that I want to import the Word table to, the table never pastes into the sheet called "Scraping Sheets" I've messed around with the code, but the closest thing I could get was placing the entire table into one cell with all formatting lost.
Private Sub CommandButton22_Click()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
Dim tbl As Object
FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _
On Error Resume Next
Set oWordApp = GetObject(, "Word.Applicaton")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(FlName)
Set tbl = oWordDoc.Tables(1)
Dim wb As Workbook, ws As Worksheet
Set wb = Workbooks.Open(""C:\Users\xxxx\Desktop\292 Int'l_Weekly_Win_Loss_YYYY MM DD TEMPLATE.xlsm"")
Set ws = wb.Sheets("Scraping Sheet")
tbl.Range.Copy
ws.Range("A1").Activate
ws.Paste
MsgBox "Successfully Added File!"
End Sub