HI experts
i have set of data in excel start from A7 with header, i want copy data one by one into word file with image where stored in desktop
In column images saved path contain
please find the attachment and expected result in word
Hi Mani,
It's a complex setup you need to make, before exporting data:
Insert Content Controls in your word document, named exactly as your excel named ranges that you want to send.
Use this code to send excel named ranges into word content controls:
Sub SendExcelDataToWord()
Dim Tbl As Excel.Range, x As Byte, WdTbl As Object
Dim WordApp As Object, ExitPoint As Label
Dim myDoc As Object
Dim BookmarkArray As Variant
BookmarkArray = Array("RangeName1", "RangeName2", "RangeName3") ' excel named ranges to transfer into same ContentControl names
Application.ScreenUpdating = False
Application.EnableEvents = False
Set myDoc = GetWordDocument( "E:DocsWordDocName.docx")
if mydoc is nothing then goto ExitPoint
For x = LBound(BookmarkArray) To UBound(BookmarkArray)
If myDoc.SelectContentControlsByTitle(BookmarkArray(x)).Count = 0 Then
MsgBox "Content Control not found: ''" & BookmarkArray(x) & "''."
Else
Set Tbl = ThisWorkbook.Names(BookmarkArray(x)).RefersToRange ' if there is no such range name, code will fail, error is not handled
Tbl.Copy
myDoc.SelectContentControlsByTitle(BookmarkArray(x))(1).Range.Text = ""
myDoc.SelectContentControlsByTitle(BookmarkArray(x))(1).Range.PasteAndFormat (22) '10 is wdTableAppendTable
End If
Next x
ExitPoint:
Set myDoc = Nothing
Set Tbl = Nothing
Set WdTbl = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.CutCopyMode = False
End Sub
Function to open the word document:
Function GetWordDocument(ByVal DocPath As String) As Object
Dim Fname As String, BMRange As Object, Cell As Range, NotOpen As Label, OpenAlready As Label, FilePath As String
Dim WdApp As Object, WdDoc As Object, i As Integer, Nm As String, ExitLine As Label
ChDir ThisWorkbook.Path
FilePath = Left(DocPath, InStrRev(DocPath, ""))
Fname = Replace(DocPath, FilePath, "")
'try to open it, it might be in the right place
Application.DisplayAlerts = False
On Error Resume Next
Set WdApp = GetObject(, "Word.Application")
If WdApp Is Nothing Then Set WdApp = CreateObject("Word.Application")
Set WdDoc = WdApp.Documents(Fname)
If WdDoc Is Nothing Then Set WdDoc = WdApp.Documents.Open(DocPath)
If WdDoc Is Nothing Then
Fname = Application.GetOpenFilename("Word files (*.do*),*.do*", , "Select " & Fname & " (Word document)")
If Fname = "False" Then Exit Function
FilePath = Left(Fname, InStrRev(Fname, ""))
Set WdDoc = WdApp.Documents.Open(Fname)
End If
On Error GoTo 0
Application.DisplayAlerts = True
WdApp.Visible = True
Set GetWordDocument = WdDoc
End Function
Thanks for replied with code Thanks for valuable code
