Excel data to Word with images

[HulkSplash]

Thanks for taking a look at my issue. I will say upfront that this week has been my first experience with VBA. I've had previous experience with SQL queries and Powershell, but I have zero knowledge of VBA before this week started. After reading too many forums and too many articles, I'll admit I'm lost in my own mind.

I'm trying to build a script to capture data from an Excel sheet that will have an unknown number of rows, but a fixed number of columns. No headers are necessary. Excel file layout below. (Example will be provided in zip file -- Batch_Example.xls)

Column A: BatchNumber
Column B: UniqueID
Column C: MemberID
Column D: CodeID
Column E: PaidDollars
Column F: DiffDollars (not required)


For each row in the sheet, take that row of data and populate a specific page in Word, and just to make things very interesting (if this is even possible), add an image that corresponds with the UniqueID in Column B. (Also included in the zip file). The Finished_Product_Example.doc contains what the output should look like.


Sub PrintCell()


Set WordObj = CreateObject("Word.Application")


WordObj.Visible = True


WordObj.Documents.Add


With WordObj.Selection


.TypeText Text:="Batch # "
.TypeText Text:=Sheets("Sheet1").Range("A1").Value
.TypeText Text:=vbTab
.TypeText Text:=vbTab


.TypeText Text:="ICN # "
.TypeText Text:=Sheets("Sheet1").Range("B1").Value
.TypeText Text:=vbTab
.TypeText Text:=vbTab


.TypeText Text:="EnrolleeID "
.TypeText Text:=Sheets("Sheet1").Range("C1").Value


.TypeParagraph


.TypeText Text:="Reason Code "
.TypeText Text:=Sheets("Sheet1").Range("D1").Value
.TypeText Text:=vbTab
.TypeText Text:=vbTab


.TypeText Text:="Paid $ "
.TypeText Text:=Sheets("Sheet1").Range("E1").Value
.TypeText Text:=vbTab
.TypeText Text:=vbTab
.TypeText Text:=vbTab
.TypeText Text:=vbTab


.TypeText Text:="Difference $ "
.TypeText Text:=Sheets("Sheet1").Range("F1").Value


.Selection.InsertBreak Type:=wdPageBreak


End With


Set WordObj = Nothing


End Sub


The above code is the best I've got right now, and it doesn't work! Again, I know next to nothing about VBA, but I do realize that I'm obviously doing this wrong. I realize that writing a ton of code for specific cells is not optimal, but I'm not sure on how to write the loops to get the data into Word. Images will be kept in a static folder on the server and they will be saved as a .jpg.

I'm open to anything. Thanks for looking at this, and please let me know if I've left anything out.

11586

[patel]

Why you want doc files instead of xls files ?

[mancubus]

here is something to play with.

as it needs to be corrected and fine tuned, maybe opening a thread in Word Help forum will be more helpful.



Sub xl_wd_PrintCell()

Dim fPath As String
fPath = ThisWorkbook.Path & "\"
With CreateObject("Word.Application")
.Visible = True
.Documents.Add
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
With .Selection
.TypeText Text:="Batch # " & Range("A" & i).Value & String(2, vbTab)
.TypeText Text:="ICN # " & Range("B" & i).Value & String(2, vbTab)
.TypeText Text:="EnrolleeID " & Range("C" & i).Value
.TypeParagraph
.TypeText Text:="Reason Code " & Range("D" & i).Value & String(2, vbTab)
.TypeText Text:="Paid $ " & Range("E" & i).Value & String(4, vbTab)
.TypeText Text:="Difference $ " & Range("F" & i).Value
.TypeParagraph
End With
.ActiveDocument.InlineShapes.AddPicture (fPath & Range("B" & i).Value & ".jpg")
With .Selection
.TypeParagraph
.EndKey wdStory, wdMove
.Range.InsertBreak
End With
Next
.ActiveDocument.SaveAs fPath & "finished"
End With

End Sub

[HulkSplash]

Patel, I figured this would be the easiest way for presentation purposes. But after seriously circling back and forth to your question, I really have no reason to export it to Word. I could keep it in Excel and just have the data from Sheet1 sent to the rest of the sheets in the workbook with the image.

Mancubus, thank you for the streamlined code. I sincerely appreciate it! I'll get to tuning it.

[patel]

Sub InsertText_PICTURE()
Dim WordApp As Object
fPath = ThisWorkbook.Path & "\"
Set WordApp = CreateObject("Word.Application")
With WordApp
.Visible = True
.Documents.Add
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
With .Selection
.TypeText Text:="Batch # " & Range("A" & i).Value & String(2, vbTab)
.TypeText Text:="ICN # " & Range("B" & i).Value & String(2, vbTab)
.TypeText Text:="EnrolleeID " & Range("C" & i).Value
.TypeParagraph
.TypeText Text:="Reason Code " & Range("D" & i).Value & String(2, vbTab)
.TypeText Text:="Paid $ " & Range("E" & i).Value & String(4, vbTab)
.TypeText Text:="Difference $ " & Range("F" & i).Value
.TypeParagraph
.InlineShapes.AddPicture (fPath & Range("B" & i).Value & ".jpg")
.TypeParagraph
.Range.InsertBreak
.MoveDown

End With
Next
.ActiveDocument.SaveAs fPath & "finished"
End With
End Sub

[HulkSplash]

Thank you Patel for another version of the code. I was getting an error on your code at the .InlineShapes portion.

Here's what I've got thanks to your and Mancubus' code, in terms of getting the data into Word. There is an issue with how the layout works, as the code currently takes all the images and places them all on their own page but they do not contain the Excel values on the same page. In fact, the images are on their own page, but the excel values are on their own separate page, and the layout ends up with 2 extra blank pages at the bottom.


Sub xl_wd_PrintCell()

Const wdstory = 6
Const wdmove = 0
Const wdpagebreak = 7

Dim fPath As String
fPath = ThisWorkbook.Path & "\Images\"
With CreateObject("Word.Application")
.Visible = True
.Documents.Add
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
With .Selection
.TypeText Text:="Batch # " & Range("A" & i).Value & String(2, vbTab)
.TypeText Text:="ICN # " & Range("B" & i).Value & String(2, vbTab)
.TypeText Text:="EnrolleeID " & Range("C" & i).Value
.TypeParagraph
.TypeText Text:="Reason Code " & Range("D" & i).Value & String(2, vbTab)
.TypeText Text:="Paid $ " & Range("E" & i).Value & String(4, vbTab)
.TypeText Text:="Difference $ " & Range("F" & i).Value
.TypeParagraph
End With

.ActiveDocument.InlineShapes.AddPicture (fPath & Range("B" & i).Value & ".jpg")

With .Selection

.TypeParagraph
.EndKey wdstory, wdmove
.Range.InsertBreak (wdpagebreak)

End With
Next
.ActiveDocument.SaveAs (fPath & Range("A1").Value)
End With

End Sub




I'm going to keep plugging away at this, but I just wanted to say thank you one more time. I'm 90% of the way home, with just some fine tuning on the layouts to go. Again, I thank you both for your efforts and guidance!

[mancubus]

opening a thread in Word Help forum will be more helpful.

i recommend (again) you open a tread in this forum and ask word gurus' help.

[snb]

@mancubus

No need to:


Sub M_snb()
sn=cells(1).currentregion

With CreateObject("Word.Document")
For j = 1 To ubound(sn)
.content.insertafter "Batch # " & replace(replace(replace(replace(replace(join(application.index(sn,j),"~ # " &string(2,vbtab)),"~","ICN",, 1),"~","EnrolleeID",,1),"~",vbcr & "Reason code",,1),"~","Paid $",,1),"~","Difference $",,1) & string(2,vbcr)

.paragraphs.last.range.InlineShapes.AddPicture ThisWorkbook.Path & "\Images\" & sn(j,2) & ".jpg"
.content.insertafter vbcr
.content.insertbreak
next
.visible=true
.SaveAs2 ThisWorkbook.Path & sn(1,1)
End With
End Sub

[mancubus]

@snb

to handle errors it threw, i changed document to application, added .Documents.Add and With block.

no errors now. but the code only creates an instance of word; nothing more.

how do you modify the code to make it work?




Sub M_snb()
sn = Cells(1).CurrentRegion

With CreateObject("Word.Application")
.Visible = True
.Documents.Add
With ActiveDocument
For j = 1 To UBound(sn)
.Content.InsertAfter "Batch # " & Replace(Replace(Replace(Replace(Replace(Join(Application.Index(sn, j), "~ # " & String(2, vbTab)), "~", "ICN", , 1), "~", "EnrolleeID", , 1), "~", vbCr & "Reason code", , 1), "~", "Paid $", , 1), "~", "Difference $", , 1) & String(2, vbCr)
.Paragraphs.Last.Range.InlineShapes.AddPicture ThisWorkbook.Path & "\Images\" & sn(j, 2) & ".jpg"
.Content.InsertAfter vbCr
.Content.InsertBreak
Next
.SaveAs2 ThisWorkbook.Path & sn(1, 1)
End With
End With
End Sub

[snb]

No errors (Excel 2010) using:


Sub M_snb()
sn = Cells(1).CurrentRegion

With CreateObject("Word.Document")
For j = 1 To UBound(sn)
.Content.InsertAfter "Batch # " & String(2, vbTab) & Replace(Replace(Replace(Replace(Replace(Join(Application.Index(sn, j), "~ # " & String(2, vbTab)), "~", "ICN", , 1), "~", "EnrolleeID", , 1), "~", vbCr & "Reason code", , 1), "~", "Paid $", , 1), "~", "Difference $", , 1) & String(2, vbCr)
.Paragraphs.Last.Range.InlineShapes.AddPicture "G:\mijn afbeeldingen\peer.jpg"
.Content.InsertAfter vbCr
.Paragraphs.Last.Range.InsertBreak
Next
.Application.Visible = True
' .SaveAs2 ThisWorkbook.Path & sn(1, 1)
End With
End Sub

All data will be inserted in the Word document.
PS. you need some data in cells(1).currentregion (A1:Fx)

[mancubus]

thanks.
great code indeed.
:clap:

[mancubus]

@HulkSplash

you can adopt snb's last code like this:


Sub M_snb()
sn = Cells(1).CurrentRegion

With CreateObject("Word.Document")
For j = 1 To UBound(sn)
.Content.InsertAfter "Batch # " & String(2, vbTab) & Replace(Replace(Replace(Replace(Replace(Join(Application.Index(sn, j), "~ # " & String(2, vbTab)), "~", "ICN", , 1), "~", "EnrolleeID", , 1), "~", vbCr & "Reason code", , 1), "~", "Paid $", , 1), "~", "Difference $", , 1) & String(2, vbCr)
.Paragraphs.Last.Range.InlineShapes.AddPicture ThisWorkbook.Path & "\Images\" & sn(j, 2) & ".jpg"
.Content.InsertAfter vbCr
.Paragraphs.Last.Range.InsertBreak
Next
.Application.Visible = True
.SaveAs2 ThisWorkbook.Path & "\" & "FileNameYouWishHere"
End With
End Sub


ThisWorkbook.Path & "\Images\" must be read as the picture files are in Images subfolder of the folder that contains the master workbook whose code module above script will be pasted in. so change it to suit.

[mancubus]

for those who are unfamiliar with the nested functions and array functions, the first line in the loop is worth paying attention to.

it can be divided as below for readability:



"Batch # " & String(2, vbTab) & _
Replace( _
Replace( _
Replace( _
Replace( _
Replace( _
Join(Application.Index(sn, j), "~ # " & String(2, vbTab)), _
"~", "ICN", , 1), _
"~", "EnrolleeID", , 1), _
"~", vbCr & "Reason code", , 1), _
"~", "Paid $", , 1), _
"~", "Difference $", , 1) _
& String(2, vbCr)


Application.Index(sn, j) returns jth "row" of the array, which is also an array.

Join(Application.Index(sn, j), "~ # " & String(2, vbTab)) joins this 1D array's elements with delimeter "~ # " & String(2, vbTab) in a "string".

so when j is equal to 1 this string is:
008052277 ~ # 2Tabs 1965056200089901 ~ # 2Tabs 20001040525 ~ # 2Tabs 4721 ~ # 2Tabs 18.27 ~ # 2Tabs 38.27

5 nested replace functions replace the "~"s with "ICN", "EnrolleeID", vbCr & "Reason code", "Paid $" and "Difference $" in this in this string respectively.

, 1 are the arguments of replace function. 1 is for Count argument. (google "excel vba replace function" for more.)

[snb]

the 1-argument in 'replace' is indicating the number of replacements.
As you may notice in my code I avoid any 'selection'. If possible I always refer to a certain element (object like 'paragraph' or 'content') directly.


Sub M_snb()
sn = Cells(1).CurrentRegion
sp=split("ICN_EnrolleeID_Reason code_Paid_Difference","_")

With CreateObject("Word.Document")
For j = 1 To UBound(sn)
c00=Join(Application.Index(sn, j), "~ # " & String(2, vbTab))

for jj=0 to ubound(sp)
c00=replace(c00,"~",sp(jj),,1)
next

.Content.InsertAfter "Batch # " & String(2, vbTab) & replace(c00,"Reason",vbcr & "Reason") & String(2, vbCr)
.Paragraphs.Last.Range.InlineShapes.AddPicture "G:\mijn afbeeldingen\peer.jpg"
.Content.InsertAfter vbCr
.Paragraphs.Last.Range.InsertBreak
Next
.Application.Visible = True
' .SaveAs2 ThisWorkbook.Path & sn(1, 1)
End With
End Sub

[mancubus]

thanks for the correction. i modified the related part of my message. i removed the , as well.


ps:
- closing ) in "Join..." line and " in ".Content.InsertAfter..." line are missing in the second macro.
- and the places of tabs can be tuned, i think.

[HulkSplash]

Mancubus and Snb,

Thank you for a plethora of information to absorb! I've got the rest of my day assigned to learning more about this, and using this as an example. Some tweaking with the tabs are necessary, but that's nothing for you all to concern yourself with. Again, thank you all!

[mancubus]

you are welcome.