Export from excel to word: How to cluster text in MS Word, no line spacing

[perola.rike]

I have a spreadsheet that creates scores from cognitive tests. From the numbers that are generated I programmed excel to export apropriate text lines/reports based on the numbers.

Every number/cognitive test is on a separate row in excel. When excel export to word the report in word also have separate lines. I want the ms word report to be clustered together, continously, with no line spacing/divisions between the textlines (which represent each test).

How can I do this?

The code for xls to word goes like this:

__________________________________

Private Sub CommandButton2_Click()


'
' ms_word_export_gen Makro
' Makro registrert 13.02.2012 av Elisabeth Rognum
'Eksporterer generatoren til word, denne kan limes inn i dips

'
' Creates Word document of Auction Items using Automation

Dim WordApp As Object
Dim LastRow As Integer, i As Integer, r As Integer, Records As Integer

On Error Resume Next
Application.ScreenUpdating = False

' Start Word And create an Object
Set WordApp = CreateObject("Word.Application")
With WordApp
.Documents.Add
End With

' Determine the file name
WSName = "Oppstart"
'change "Sheet1" to sheet tab name containing cell reference
CName = "Navn"
'change "A1" to the cell with your date
savename = Sheets(WSName).Range(CName).Text
SaveAsName = ThisWorkbook.Path & "\" & "Autorapport " & savename & ".doc"

' Sort Worksheet into proper catalog order
Sheets("Items").Select
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, _
Key1:=Range("C2"), Order3:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A2").Select

' Delete Empty rows from "Items" worksheet
LastRow = Selection.SpecialCells(xlCellTypeLastCell).Rows.Row
Application.StatusBar = "Deleting Empty Rows from " & LastRow & " Used Rows"
' Cycle through all records In Items
For r = LastRow To 1 Step -1
If Application.WorksheetFunction.CountA(Rows(r)) = 0 _
Then Rows(r).Delete
Next r

' Update Last Row value In Case rows were deleted
Sheets("Items").Range("Title").FormatConditions.Delete
Records = ActiveSheet.UsedRange.Rows.Count

' Information from worksheet
Set Data = Sheets("generator").Range("G12")

' Cycle through all records In Items

For i = 2 To Records
' Update status bar progress message
Application.StatusBar = "Processing Record " & i & " of " & Records

' Assign current data To variables
Letter = Data.Offset(i - 1, 0).Value
Number = Data.Offset(i - 1, 1).Value
Title = Data.Offset(i - 1, 2).Value
Descript = Data.Offset(i - 1, 3).Value
FMV = Format(Data.Offset(i - 1, 4).Value, "#,000")
FMText = Data.Offset(i - 1, 5).Value
Donor = Data.Offset(i - 1, 6).Value

' Send commands To Word
With WordApp
With .Selection
.TypeParagraph
.Font.Name = "Times New Roman"
.Font.Size = 12
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=Letter & Number & " "
.Font.Underline = True
.Font.AllCaps = True
.TypeText Text:=Title
.Font.AllCaps = False
.Font.Bold = False
.Font.Underline = False

End With
End With
Next i

' Save the Word file And Close it
With WordApp
.ActiveDocument.SaveAs Filename:=SaveAsName
.ActiveWindow.Close
' Kill the Object
.Quit
End With

Set WordApp = Nothing

' Reset status bar
Application.StatusBar = ""
MsgBox "Autorapport " & savename & ".doc was saved in " & ThisWorkbook.Path
End Sub