Copying and pasting between Excel and Word could be brutally slow. If you just need the data, then perhaps you could use something like this:
Option Explicit
Private m_arrData As Variant
Private m_strDemoExcelFile As String
Sub ExamplesWithExcel()
Dim lngIN As Long
Dim lngX As Long, lngY As Long
Dim strRecord As String
m_strDemoExcelFile = ThisDocument.Path & "\Book1.xlsx"
lngIN = InputBox("Enter and Item Number", "Item Number", 1)
m_arrData = fcnADODB(m_strDemoExcelFile, "Sheet1$", "WHERE [Item Number] = " & lngIN)
For lngX = 0 To UBound(m_arrData, 2)
strRecord = vbNullString
For lngY = 1 To UBound(m_arrData, 1)
Select Case lngY
Case 1: strRecord = m_arrData(lngY, lngX)
Case UBound(m_arrData, 1): strRecord = strRecord & " " & m_arrData(lngY, lngX) & vbCr
Case Else: strRecord = strRecord & " " & m_arrData(lngY, lngX)
End Select
Next lngY
Selection.Range.InsertAfter strRecord
Selection.Collapse wdCollapseEnd
Next lngX
lbl_Exit:
Exit Sub
End Sub
Public Function fcnADODB(DataBasePath As String, ByVal Table As String, _
Optional Filter As String = vbNullString) As Variant
Dim SQLStatement As String
Dim lngNumRecs As Long, lngIndex As Long
Dim strConnection As String
Dim oConn As Object, oCatalog As Object
Dim oRS As Object
Dim arrData As Variant
'Initialize variables.
fcnADODB = vbNullString
strConnection = "Provider=Microsoft.ACE.OLEDB.15.0;" & _
"Data Source=" & DataBasePath & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Table = "[" & Table & "]"
SQLStatement = Trim("SELECT * FROM " & Table & " " & Filter) & ";"
On Error GoTo Err_Report
Set oConn = CreateObject("ADODB.Connection")
oConn.Open ConnectionString:=strConnection
Set oRS = CreateObject("ADODB.Recordset")
'Get the data
oRS.Open SQLStatement, oConn, 3 'Note - 3 represents cursorLocation adOpenStatic constant. Needed for record count.
'Determine if data found and get record count.
With oRS
If Not .EOF Then
.MoveLast
lngNumRecs = .RecordCount
.MoveFirst
fcnADODB = oRS.GetRows(lngNumRecs)
End If
End With
lbl_Cleanup:
If Not oRS Is Nothing Then
If oRS.State = 1 Then oRS.Close
End If
Set oRS = Nothing
lbl_Exit:
If Not oConn Is Nothing Then
If oConn.State = 1 Then oConn.Close
End If
Set oConn = Nothing
Exit Function
Err_Report:
Application.StatusBar = Err.Number
If InStr(Err.Description, "Data type mismatch in criteria ") = 1 Then
fcnADODB = "Failed Data Mismatch"
Resume lbl_Cleanup
End If
fcnADODB = Err.Description
Resume lbl_Cleanup
End Function