How JustAnswer Works:

  • Ask an Expert
    Experts are full of valuable knowledge and are ready to help with any question. Credentials confirmed by a Fortune 500 verification firm.
  • Get a Professional Answer
    Via email, text message, or notification as you wait on our site.
    Ask follow up questions if you need to.
  • 100% Satisfaction Guarantee
    Rate the answer you receive.

Ask Richard Your Own Question

Richard
Richard, Software Specialist
Category: Microsoft Office
Satisfied Customers: 32976
Experience:  Over 15 year experience resolving Microsoft Office Issues
32989067
Type Your Microsoft Office Question Here...
Richard is online now
A new question is answered every 9 seconds

I'm trying to create a macro in Excel that will transfer

Customer Question

I'm trying to create a macro in Excel that will transfer each row of data in the Excel spreadsheet to a different Word document.

Submitted: 1 year ago.
Category: Microsoft Office
Expert:  Suryanto replied 1 year ago.

Hi,

Welcome to Justanswer

I am Suryanto and I can help you with the macro.

Could you send me a copy of your file (please remove sensitive data) ?
You can attach the sample file using the paper clip icon in the reply box.

Please let me know by replying to me here so that I can help you further

Thank you

Suryanto

Customer: replied 1 year ago.

file types can only be the following: jpg, jpeg, gif, png, bmp, tiff, raw, zip, rar, pdf, doc, xls, ppt, docx, xlsx, swf, flv, fla, wmv

I have a xlsm file

In my original message I have images of the Excel document and a Word document on how the output should look

Customer: replied 1 year ago.

Attachment: 2015-12-30_183054_data.xls

Here is my incorrect VBA code

Option Explicit

Sub ReformatCIMS()

Dim WrdApp As Word.Application
Dim WrdDoc As Word.Document
Dim intLoop As Integer
Dim lngCount As Long
Dim loc As Long

Set WrdApp = CreateObject("Word.Application")

Set WrdDoc = WrdApp.Documents.Open("D:\")
With WrdApp.Visible = True
Set WrdDoc = .Documents.Add
End With

'option to load a template file
' WrdApp.Visible = True
' Set WrdDoc = WrdApp.Documents.Open("D:\")

lngCount = 0

With WrdDoc

.Content.Font.Size = 12

For intLoop = 5 To 6

lngCount = lngCount + 1

' insert pagefeed after first page
If lngCount > 1 Then
.Content.InsertAfter Chr(12)
End If

'insert horizontal line
.Content.InsertAfter String(77, "_")
.Content.InsertAfter vbCrLf

loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Ticket #: " & Worksheets("Sheet1").Cells(intLoop, 1).Text
'set Ticket # ***** Blue and Bold
.Content.Words.Item(loc).Font.Color = wdColorBlue
.Content.Words.Item(loc).Font.Bold = True
.Content.Words.Item(loc + 1).Font.Color = wdColorBlue
.Content.Words.Item(loc + 1).Font.Bold = True

.Content.InsertAfter vbTab & vbTab
loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Date: " & Worksheets("Sheet1").Cells(intLoop, 2).Value & vbCrLf
'Set Date Heading to BOLD
.Content.Words.Item(loc).Font.Color = wdColorBlack
.Content.Words.Item(loc).Font.Bold = True

loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Address: " & Worksheets("Sheet1").Cells(intLoop, 6).Value & vbCrLf
'Set Date Heading to BOLD
.Content.Words.Item(loc).Font.Color = wdColorBlack
.Content.Words.Item(loc).Font.Bold = True

loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Company Complaining About: " & Worksheets("Sheet1").Cells(intLoop, 6).Value & vbCrLf
'Set Date Heading to BOLD
.Content.Words.Item(loc).Font.Color = wdColorBlack
.Content.Words.Item(loc).Font.Bold = True

loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Company Complaining About:" & vbTab & strSubcategory & vbCrLf
.Content.Words.Item(loc).Font.Bold = True 'Set Heading to BOLD

loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Subject:" & vbTab & Worksheets("Sheet1").Cells(intLoop, 12).Value
.Content.Words.Item(loc).Font.Bold = True 'Set Heading to BOLD

.Content.InsertAfter vbCrLf
.Content.InsertAfter String(77, "_")
.Content.InsertAfter vbCrLf

With .Content.ParagraphFormat
'.SpaceBefore = 0
'.SpaceAfter = 0
End With

loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Description" & vbCrLf
.Content.Words.Item(loc).Font.Bold = True 'Set Heading to BOLD
.Content.Words.Item(loc + 1).Font.Bold = True 'Set Heading to BOLD

.Content.InsertAfter vbTab
loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Description: " & Worksheets("Sheet1").Cells(intLoop, 14).Text & " " & Worksheets("Sheet1").Cells(intLoop, 4).Text
.Content.Words.Item(loc).Font.Bold = True 'Set Heading to BOLD

.Content.InsertAfter vbTab
loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Description: " & Worksheets("Sheet1").Cells(intLoop, 14).Value & ", " & Worksheets("Sheet1").Cells(intLoop, 6).Value & " " & Worksheets("Sheet1").Cells(intLoop, 7).Value & vbCrLf & vbCrLf
.Content.Words.Item(loc).Font.Bold = True 'Set Heading to BOLD
.Content.Words.Item(loc + 2).Font.Bold = True 'Set Heading to BOLD
.Content.Words.Item(loc + 4).Font.Bold = True 'Set Heading to BOLD

loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Description" & vbCrLf
.Content.Words.Item(loc).Font.Bold = True 'Set Heading to BOLD
.Content.Words.Item(loc + 1).Font.Bold = True 'Set Heading to BOLD

.Content.InsertAfter vbTab
loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Description : " & Worksheets("Sheet1").Cells(intLoop, 9).Value & vbCrLf & vbCrLf
.Content.Words.Item(loc).Font.Bold = True 'Set Heading to BOLD

.Content.InsertAfter vbTab
loc = WrdDoc.Content.Words.Count
.Content.InsertAfter "Description: " & Worksheets("Sheet1").Cells(intLoop, 15).Value & vbCrLf
.Content.Words.Item(loc).Font.Bold = True 'Set Heading to BOLD

If Trim(Worksheets("Sheet1").Cells(intLoop, 16).Value) <> "" Then
.Content.InsertAfter " " & vbCrLf
.Content.InsertAfter " " & vbCrLf
.Content.InsertAfter "Follow-up message on " & Worksheets("Sheet1").Cells(intLoop, 17).Value & " - " & Worksheets("Sheet1").Cells(intLoop, 16).Value
End If

If Trim(Worksheets("Sheet1").Cells(intLoop, 18).Value) <> "" Then
.Content.InsertAfter " " & vbCrLf
.Content.InsertAfter " " & vbCrLf
.Content.InsertAfter "Follow-up message on " & Worksheets("Sheet1").Cells(intLoop, 19).Value & " - " & Worksheets("Sheet1").Cells(intLoop, 18).Value
End If

If Trim(Worksheets("Sheet1").Cells(intLoop, 20).Value) <> "" Then
.Content.InsertAfter " " & vbCrLf
.Content.InsertAfter " " & vbCrLf
.Content.InsertAfter "Follow-up message on " & Worksheets("Sheet1").Cells(intLoop, 21).Value & " - " & Worksheets("Sheet1").Cells(intLoop, 20).Value
End If

If Trim(Worksheets("Sheet1").Cells(intLoop, 22).Value) <> "" Then
.Content.InsertAfter " " & vbCrLf
.Content.InsertAfter " " & vbCrLf
.Content.InsertAfter "Follow-up message on " & Worksheets("Sheet1").Cells(intLoop, 23).Value & " - " & Worksheets("Sheet1").Cells(intLoop, 22).Value
End If

Next intLoop

' if old version exists, delete it
If Dir("D:\") <> "" Then
Kill "D:\"
End If

.SaveAs ("D:\")
.Close '--- close the document

End With

WrdApp.Quit ' close the Word application

Set WrdDoc = Nothing

Set WrdApp = Nothing

MsgBox ("Done.")

End Sub

Expert:  Suryanto replied 1 year ago.

Sorry for late reply because time difference

Ok.got the the file

Could you send me the format of the word file?

Thanks

Customer: replied 1 year ago.
Expert:  Suryanto replied 1 year ago.

Ok. Got the file. I will check and let you know

Thanks

Customer: replied 1 year ago.

Hello,

I was wondering if you have the code

Expert:  Suryanto replied 1 year ago.

Hi,

My apologies for the delay in getting back to you. I don't have access to computer

I will opt out and another expert will take over the question

Thank you

Customer: replied 1 year ago.
Relist: Inaccurate answer.
Customer: replied 1 year ago.
Relist: I prefer a second opinion.
Expert:  Richard replied 1 year ago.

Hi there and welcome

I have now done this for you.

It is available here

http://wikisend.com/download/264560/Book1.xlsm

You will see the button to run it, click it, enter the path and file name to make eg: c:\test.docx

And it will do this for you.

Let me know how you go please.

Customer: replied 1 year ago.

Is there another place to download this file? The computer I'm using blocks this site

Expert:  Richard replied 1 year ago.

can you download it here?

http://ge.tt/160OOfV2/v/0?c

Customer: replied 1 year ago.

I manged to download the file on another computer and the code does not work

Expert:  Richard replied 1 year ago.

ok... how does it not work as its running fine for me?

Customer: replied 1 year ago.
I get a compile error when I try to run it
Expert:  Richard replied 1 year ago.

which version of windows and excel are you using? It works fine on the computers I checked so will be an issue with the computer your running it on.

Customer: replied 1 year ago.
I use Windows 7. I'll try on my Mac
Expert:  Richard replied 1 year ago.

which version of windows and excel are you using?

Customer: replied 1 year ago.
Excel 2013
Expert:  Richard replied 1 year ago.

run it in excel 2010 and tell me if you get the error.

Related Microsoft Office Questions