How can I populate a simple Word form field with some data from an excel worksheet :)

[Process153]

Hello all,

Problem: I need to pass the contents of an excel spread sheet to a field in a Word form I am creating. I've created a button which runs the code below and my hope is that I can get the contents of the spread sheet displayed in the field I have chosen. I don't need it to do anything fancy once its there, just be visible. Im a bit of a newb at VBA but keen! Really appreciate any help and guidance!

Office Version: 2013

Current Code:

Private Sub ImportExcelData_Click()


Dim xlapp As Object
Dim xlwbk As Object
Set xlwbk = objExcel.Workbooks.Open("C:\etc")
ThisDocument.AddExcelData = exWb.Sheets("Sheet1").Rows(B, D, E, G, H, J)
exWb.Close
Set exWb = Nothing

[gmayor]

What sort of a field? Do you simply want to display the whole worksheet, or do you want to display some data from it?
See http://www.gmayor.com/Userform_ComboBox.html and if that's not what you mean, can you supply more information.

[Process153]

Hi Graham,

Your link is blocked at my end so will have a look at home. To be honest, I'm not too fussy about the field format. As long as the reader can see the result. The data could be 1 or more rows of data with maybe 10 columns so... In Excel the rows look like this:



Employee Number

Contract Number

Item Type

Description

Cost






I'd like to just click a button and have it copy and paste the contents of the target excel range onto the Word document I am creating. (so, A1 to A10) and so on.

Thanks for your reply!

[gmaxey]

I'm not an Excel expert by any means but to the best of my knowledge and Excel range is a depiction of a Base 1 Variant array. So with that in mind the data would have to be extracted from the array into a string or placed in a Word table. Lets assume your form contains a rich text content control titled "Excel Data"


Private Sub ImportExcelData_Click()
Dim xlapp As Object
Dim xlwbk As Object
Dim oSheet As Object
Dim oCC As ContentControl
Dim oTbl As Word.Table
Dim varData
Dim lngRow As Long, lngCol As Long
Set xlapp = CreateObject("Excel.Application")
Set xlwbk = xlapp.Workbooks.Open("H:\Book1.xlsx")
Set oSheet = xlwbk.Worksheets("Sheet1")
varData = oSheet.Range("A1:D2").Value
xlwbk.Close
xlapp.Quit
Set oCC = ActiveDocument.SelectContentControlsByTitle("Excel Data").Item(1)
oCC.Range.Delete
Set oTbl = oCC.Range.Tables.Add(oCC.Range, UBound(varData), UBound(varData, 2))
For lngRow = 1 To UBound(varData)
For lngCol = 1 To UBound(varData, 2)
oTbl.Cell(lngRow, lngCol).Range.Text = varData(lngRow, lngCol)
Next
Next
lbl_Exit:
Exit Sub
End Sub

[gmayor]

Rather than open the workbook, you can read the worksheet into an array and grab the columns and rows you require. This is much faster in practice.

The following is a minor variation on a function I use myself to insert Excel data into a table. The example creates a three column table (add as many columns as you require using the same principles) and inserts values from columns 7,8 and 9, with the header row from those columns.

The rows inserted are those specified in the calling macro InsertTable - here rows 10 to 15 from a much larger worksheet (where 10 is counted from the row below the header row). The example inserts the table at the cursor, but you can enter a range instead.


Option Explicit

Sub InsertTable()
GetXLRange 10, 15, "C:\Path\WorkbookName.xlsx", "Sheetname", Selection.Range
End Sub

Private Sub GetXLRange(iStartRow As Long, _
iEndRow As Long, _
strWorkBook As String, _
strSheet As String, _
oRng As Range)
Dim Arr() As Variant
Dim iCol As Long
Dim oTable As Table
Dim oCell As Range
Arr = xlFillArray(strWorkBook, strSheet, True, False)
'add a three column table
Set oTable = oRng.Tables.Add(oRng, 1, 3)
Set oCell = oTable.Rows.Last.Cells(1).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(7, 0) 'column 7, row 0 (header)
Set oCell = oTable.Rows.Last.Cells(2).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(8, 0) 'column 8, row 0
Set oCell = oTable.Rows.Last.Cells(3).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(9, 0) 'column 9, row 0

For iCol = iStartRow To iEndRow
oTable.Rows.Add
Set oCell = oTable.Rows.Last.Cells(1).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(7, iCol)
Set oCell = oTable.Rows.Last.Cells(2).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(8, iCol)
Set oCell = oTable.Rows.Last.Cells(3).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(9, iCol)
Next iCol
lbl_Exit:
Exit Sub
End Sub

Private Function xlFillArray(strWorkBook As String, _
strWorksheetName As String, _
bIsSheet As Boolean, _
bIncludeHeaderRow As Boolean) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long
Dim strHead As String

If bIsSheet Then
strWorksheetName = strWorksheetName & "$]"
End If

Set CN = CreateObject("ADODB.Connection")
If bIncludeHeaderRow Then
strHead = "YES"
Else
strHead = "NO"
End If
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkBook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=" & strHead & Chr(34) & ";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

[gmaxey]

Graham,

Yes, I think we have shared a version of that code before. The case of ADODB methods returns a 0 Base variant array arranged column row (vice row column). So with and adaptation of my previous code, you can create and fill a table in a form rich text CC using a "named range" in the worksheet:

153, this method is much faster, but you will have to create named ranges in your excel file.





Sub ImportExcelData_Click()
Dim strWB As String
Dim strNamedRange As String
Dim oCC As ContentControl
Dim oTbl As Word.Table, lngX As Long, lngY As Long
Dim varData() As Variant
Set oCC = ActiveDocument.SelectContentControlsByTitle("Excel Data").Item(1)
On Error Resume Next
oCC.Range.Delete
oCC.Range.Tables(1).Delete
On Error GoTo 0
varData = xlFillVariant("H:\Book1.xlsx", "A1_A10", False, "No")
Set oTbl = oCC.Range.Tables.Add(oCC.Range, UBound(varData, 2) + 1, UBound(varData) + 1)
For lngX = 0 To UBound(varData, 2)
For lngY = 0 To UBound(varData)
If Not IsNull(varData(lngY, lngX)) Then
oTbl.Cell(lngX + 1, lngY + 1).Range.Text = varData(lngY, lngX)
End If
Next
Next
oCC.Range.Characters(1).Delete
lbl_Exit:
Exit Sub
End Sub

Private Function xlFillVariant(strWorkBook As String, _
strNamedRangeOrSheet As String, _
bIsSheet As Boolean, _
Optional strExcludeHeadingRow = "Yes") As Variant
Dim oRS As Object
Dim oCN As Object
Dim lngRows As Long

Set oCN = CreateObject("ADODB.Connection")
oCN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkBook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=" & strExcludeHeadingRow & Chr(34) & ";"
Set oRS = CreateObject("ADODB.Recordset")
If bIsSheet Then
strNamedRangeOrSheet = strNamedRangeOrSheet & "$]"
Else
strNamedRangeOrSheet = strNamedRangeOrSheet & "]"
End If
oRS.Open "SELECT * FROM [" & strNamedRangeOrSheet, oCN, 2, 1
With oRS
.MoveLast
lngRows = .RecordCount
.MoveFirst
End With
xlFillVariant = oRS.GetRows(lngRows)
If oRS.State = 1 Then oRS.Close
Set oRS = Nothing
If oCN.State = 1 Then oCN.Close
Set oCN = Nothing
lbl_Exit:
Exit Function
End Function

[gmaxey]

Graham,

I experience an out of range error when I ran your code on a sheet looking like this


The issue appeared to be the zero based array. I modified your code as follows and it worked for me.




Sub InsertTable()
GetXLRange 10, 15, "H:\Book1.xlsx", "Sheet1", Selection.Range
End Sub

Private Sub GetXLRange(iStartRow As Long, iEndRow As Long, _
strWorkBook As String, strSheet As String, _
oRng As Range)
Dim Arr() As Variant
Dim iCol As Long
Dim oTable As Table
Dim oCell As Range
Arr = xlFillArray(strWorkBook, strSheet, True, False)
'add a three column table
Set oTable = oRng.Tables.Add(oRng, 1, 3)
Set oCell = oTable.Rows.Last.Cells(1).Range
oCell.End = oCell.End - 1
'***GKM - Offet Arr(# to account for zero based array.
oCell.Text = Arr(6, 0) 'column 7, row 0 (header)
Set oCell = oTable.Rows.Last.Cells(2).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(7, 0) 'column 8, row 0
Set oCell = oTable.Rows.Last.Cells(3).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(8, 0) 'column 9, row 0

For iCol = iStartRow To iEndRow
oTable.Rows.Add
'***GKM - Offet Arr(#, iCol) to account for zero based array.
Set oCell = oTable.Rows.Last.Cells(1).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(6, iCol - 1)
Set oCell = oTable.Rows.Last.Cells(2).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(7, iCol - 1)
Set oCell = oTable.Rows.Last.Cells(3).Range
oCell.End = oCell.End - 1
oCell.Text = Arr(8, iCol - 1)
Next iCol
lbl_Exit:
Exit Sub
End Sub

Private Function xlFillArray(strWorkBook As String, _
strWorksheetName As String, _
bIsSheet As Boolean, _
bIncludeHeaderRow As Boolean) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long
Dim strHead As String

If bIsSheet Then
strWorksheetName = strWorksheetName & "$]"
End If

Set CN = CreateObject("ADODB.Connection")
If bIncludeHeaderRow Then
strHead = "YES"
Else
strHead = "NO"
End If
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkBook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=" & strHead & Chr(34) & ";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

[gmaxey]

Graham,

Tinkered with this code a bit this afternoon. Using the same data shown above, with the names in a name range ("Named_Range") each of the following methods works nicely and for the purpose the OP seems to want, the revision of your method seems best:


Option Explicit
Private Sub ImportExcelData_Click1()
Dim xlapp As Object
Dim xlwbk As Object
Dim oSheet As Object
Dim oCC As ContentControl
Dim oTbl As Word.Table
Dim varData
Dim lngRow As Long, lngCol As Long
Set xlapp = CreateObject("Excel.Application")
Set xlwbk = xlapp.Workbooks.Open("H:\Book1.xlsx")
Set oSheet = xlwbk.Worksheets("Sheet1")
varData = oSheet.Range("G10:I15").Value
xlwbk.Close
xlapp.Quit
Set oCC = ActiveDocument.SelectContentControlsByTitle("Excel Data").Item(1)
On Error Resume Next
oCC.Range.Delete
oCC.Range.Tables(1).Delete
On Error GoTo 0
Set oTbl = oCC.Range.Tables.Add(oCC.Range, UBound(varData), UBound(varData, 2))
For lngRow = 1 To UBound(varData)
For lngCol = 1 To UBound(varData, 2)
oTbl.Cell(lngRow, lngCol).Range.Text = varData(lngRow, lngCol)
Next
Next
oCC.Range.Characters(1).Delete
lbl_Exit:
Exit Sub
End Sub
Sub ImportExcelData_Click2()
Dim strWB As String
Dim strNamedRange As String
Dim oCC As ContentControl
Dim oTbl As Word.Table, lngX As Long, lngY As Long
Dim varData() As Variant
Set oCC = ActiveDocument.SelectContentControlsByTitle("Excel Data").Item(1)
On Error Resume Next
oCC.Range.Delete
oCC.Range.Tables(1).Delete
On Error GoTo 0
'Read rFile name and path, Named range, not a named sheet, do not exclude header row.
varData = xlFillVariant("H:\Book1.xlsx", "Named_Range", False, "No")
Set oTbl = oCC.Range.Tables.Add(oCC.Range, UBound(varData, 2) + 1, UBound(varData) + 1)
For lngX = 0 To UBound(varData, 2)
For lngY = 0 To UBound(varData)
If Not IsNull(varData(lngY, lngX)) Then
oTbl.Cell(lngX + 1, lngY + 1).Range.Text = varData(lngY, lngX)
End If
Next
Next
oCC.Range.Characters(1).Delete
lbl_Exit:
Exit Sub
End Sub
Sub ImportExcelData_Click3()
Dim oCC As ContentControl
Set oCC = ActiveDocument.SelectContentControlsByTitle("Excel Data").Item(1)
On Error Resume Next
oCC.Range.Delete
oCC.Range.Tables(1).Delete
On Error GoTo 0
'Read rows 10-15, columms 7-9, File name and path, Sheet name, insert at, exclude header row.
InsertExcelRangeAsTable 10, 15, 7, 9, "H:\Book1.xlsx", "Sheet1", oCC.Range, "Yes"
oCC.Range.Characters(1).Delete
End Sub

Sub ImportExcelData_Click4()
Dim oCC As ContentControl
Set oCC = ActiveDocument.SelectContentControlsByTitle("Excel Data").Item(1)
On Error Resume Next
oCC.Range.Delete
oCC.Range.Tables(1).Delete
On Error GoTo 0
'Read rows 10-15, columms 7-9, File name and path, Sheet name, insert at, do not exclude header row.
InsertExcelRangeAsTable 10, 15, 7, 9, "H:\Book1.xlsx", "Sheet1", oCC.Range, "No"
oCC.Range.Characters(1).Delete
End Sub
Private Sub InsertExcelRangeAsTable(lngRowStart As Long, lngRowEnd As Long, _
lngColStart As Long, lngColEnd As Long, _
strWorkBook As String, strSheet As String, _
oRng As Range, Optional strExcludeHeader As String = "No")
Dim varData As Variant
Dim oTbl As Table
Dim lngIndex As Long, lngSpan As Long
Dim lngRow As Long, lngCol As Long
varData = xlFillVariant(strWorkBook, strSheet, True, strExcludeHeader)
'Add single row table with columns determined by column span
Set oTbl = oRng.Tables.Add(oRng, 1, (lngColEnd - lngColStart + 1))
If strExcludeHeader = "No" Then
lngRow = oTbl.Rows.Count
lngCol = 1
For lngIndex = lngColStart To lngColEnd
oTbl.Cell(lngRow, lngCol).Range.Text = varData(lngIndex - 1, 0)
lngCol = lngCol + 1
Next
For lngSpan = lngRowStart To lngRowEnd
oTbl.Rows.Add
lngRow = oTbl.Rows.Count
lngCol = 1
For lngIndex = lngColStart To lngColEnd
oTbl.Cell(lngRow, lngCol).Range.Text = varData(lngIndex - 1, lngSpan - 1)
lngCol = lngCol + 1
Next
Next
oTbl.Rows(1).Range.Shading.BackgroundPatternColor = wdColorGray20
Else
For lngSpan = lngRowStart To lngRowEnd
If lngSpan > lngRowStart Then oTbl.Rows.Add
lngRow = oTbl.Rows.Count
lngCol = 1
For lngIndex = lngColStart To lngColEnd
oTbl.Cell(lngRow, lngCol).Range.Text = varData(lngIndex - 1, lngSpan - 2)
lngCol = lngCol + 1
Next
Next
End If
lbl_Exit:
Exit Sub
End Sub

Private Function xlFillVariant(strWorkBook As String, _
strNamedRangeOrSheet As String, _
bIsSheet As Boolean, _
Optional strExcludeHeadingRow = "Yes") As Variant
Dim oRS As Object
Dim oCN As Object
Dim lngRows As Long

Set oCN = CreateObject("ADODB.Connection")
oCN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkBook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=" & strExcludeHeadingRow & Chr(34) & ";"
Set oRS = CreateObject("ADODB.Recordset")
If bIsSheet Then
strNamedRangeOrSheet = strNamedRangeOrSheet & "$]"
Else
strNamedRangeOrSheet = strNamedRangeOrSheet & "]"
End If
oRS.Open "SELECT * FROM [" & strNamedRangeOrSheet, oCN, 2, 1
With oRS
.MoveLast
lngRows = .RecordCount
.MoveFirst
End With
xlFillVariant = oRS.GetRows(lngRows)
If oRS.State = 1 Then oRS.Close
Set oRS = Nothing
If oCN.State = 1 Then oCN.Close
Set oCN = Nothing
lbl_Exit:
Exit Function
End Function

[Process153]

Hi,

Just back online. Thank you so much for taking the time to go over this! I will work through this today and let you know my results!

Cheers!

[Process153]

There is obviously a lot going on in this code and I think it might be a bit beyond my skill level to get working :( But... I'm very keen to get better at coding so hopefully I'll nail it :D

[Process153]

I've been trying to understand this sub:

Dim xlapp As Object
Dim xlwbk As Object
Dim oSheet As Object
Dim oCC As ContentControl
Dim oTbl As Word.Table
Dim varData
Dim lngRow As Long, lngCol As Long
Set xlapp = CreateObject("Excel.Application")
Set xlwbk = xlapp.Workbooks.Open("d:\test.xlsx")
Set oSheet = xlwbk.Worksheets("Sheet1")
varData = oSheet.Range("A1:J3").Value
xlwbk.Close
xlapp.Quit
Set oCC = ActiveDocument.SelectContentControlsByTitle("Excel Data").Item(1)
On Error Resume Next
oCC.Range.Delete
oCC.Range.Tables(1).Delete
On Error GoTo 0
Set oTbl = oCC.Range.Tables.Add(oCC.Range, UBound(varData), UBound(varData, 2))
For lngRow = 1 To UBound(varData)
For lngCol = 1 To UBound(varData, 2)
oTbl.Cell(lngRow, lngCol).Range.Text = varData(lngRow, lngCol)
Next
Next
oCC.Range.Characters(1).Delete
lbl_Exit:

Exit Sub
End Sub

I can see what it should doing but, when I run it, I get the error "the requested member of the collection does not exist". I have included a table in my form but I'm thinking I have not yet identified it to the sub.......

[gmaxey]

Do you have a rich text content control titled Excel Data in the document?

[Process153]

I will check!

[Process153]

Awesome! It works. Thank you both so much! I need to refine a few things and truly understand how everything works but I can see a lot clearer now.

I hope I can return the favours some time!