Export Word document from Excel - copy specific range and remove spaces after paragraphs?

[perola.rike]

I have an Excel WB that export reports (text only) in a Word document. The code works perfectly, the text from the Word document are always further copied and pasted into the clinical journal system at hour hospital.

To save myself a few seconds more, I'd like to include some lines of code that
1) Copy the text in Word that includes not the whole document, but only copy the visible text (the word document alwas have many lines of empty space after the last sentence...)
2) If possible, a code that "removes spaces after paragraphs" in the word document.

I previosuly spent hours to figure out 2) before, no luck

Here is the code:

Sub wordexporte(ByRef wd As Object)
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.Calculation = xlCalculationManual
        Sheets("export").Range("A1:A500").ClearContents
        Sheets("jn").Range("A:D").EntireColumn.Hidden = False
        Sheets("jn").Columns("I:I").Copy
        Sheets("jn").Range("A:D").EntireColumn.Hidden = True
        Set wsd = Sheets("export")
        With wsd
        .Range("A1:A200").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False
        End With
        ClearCell
        Worksheets("export").Range("A1:A2000").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        Dim wdApp As Object, wdDoc As Object, wdRng As Object 
        On Error Resume Next
        Set wdApp = GetObject(, "Word.Application")
        If Err.Number <> 0 Then
        Set wdApp = CreateObject("Word.Application")
        End If
        On Error GoTo 0
        Set wdDoc = wdApp.Documents.Add
        Sheets("export").Range("A1:A80").Copy
        Set wdRng = wdDoc.Range
        With wdRng
        .Collapse Direction:=0
        .Paste
        .End = .Tables(1).Range.End + 1
        .Tables(1).ConvertToText 0
        .Font.Size = 12
        .Copy 
        While .Paragraphs.Count > 1
        .Paragraphs(1).Range.Characters.Last = Chr(11)
        Wend
        End With
        wdApp.Visible = True
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.Calculation = xlCalculationAutomatic
        Application.StatusBar = False
End Sub

 

[Macropod]

It seems to me your code could be reduced to:

Sub WordExporte()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim wdApp As Object, wdDoc As Object, wdRng As Object
Dim wsd As Worksheet
Set wsd = Sheets("export")
wsd.UsedRange.EntireRow.Delete
Sheets("jn").Columns("I:I").Copy
wsd.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False
wsd.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
  Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
wsd.UsedRange.Copy
With wdDoc.Range
  .Font.Size = 12
  .PasteSpecial , False, , , 2
  .Find.Execute "^p", , , False, , , True, 1, False, "^l", 2
  .Find.Execute "^l^p", , , False, , , True, 1, False, "", 2
End With
wdDoc.Range.Copy
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End Sub

PS: When posting code, please format the code and use the code tags, indicated by the # button on the posting menu. Without the code tags, your code loses much of whatever structure it had.