exporting data to Microsoft Word

Hello everyone!

I have a problem which i'm afraid I can't solve myself. Could you help
me please? Googling hasn't helped.

I have written/botched together the following in MS Excel 2002:

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Function UserNameWindows() As String
    
    Dim lngLen As Long
    Dim strBuffer As String
    
    Const dhcMaxUserName = 255
    
    strBuffer = Space(dhcMaxUserName)
    lngLen = dhcMaxUserName
    If CBool(GetUserName(strBuffer, lngLen)) Then
        UserNameWindows = Left$(strBuffer, lngLen - 1)
    Else
        UserNameWindows = ""
    End If
End Function

Sub ExportPDF()

Dim WordDoc As Object, objWord As Variant, ProjectNumber As String, IsPandI As Boolean, Suffix As String, NameOfFile As String, CurrentUser As String

CurrentUser = UserNameWindows

'Test to see if a Worksheet is open'.
On Error Resume Next
Set wsheet = Sheets("Tabelle1")
   If wsheet Is Nothing Then 'Doesn't exist
        MsgBox "Das Macro kann ohne Tabelle nicht ausgeführt werden!", vbCritical, "ExportPDF Error"
            Set wsheet = Nothing
            Exit Sub
        Else 'Does exist
            Set wsheet = Nothing
            On Error GoTo 0
   End If

'Reset cursor position on worksheet
Cells(1, 1).Select

'Check the title of the first column. If there's nothing then stop

If Selection = "" Then
    MsgBox "Das Macro kann nur mit Listen aus Saperion ausgeführt werden!", vbCritical, "ExportPDF Error"
    Exit Sub
    End If

'Fire up Microsloth Word
Set appWD = CreateObject("word.Application")
appWD.Visible = False
 
'Open a brand spanking new Word document
Set WordDoc = appWD.Documents.Add
 
'Change the page orientation of the Word document
With WordDoc
    .PageSetup.Orientation = 1
End With

'Copy the table from Excel...
ActiveSheet.UsedRange.Select
ActiveSheet.UsedRange.Activate
Selection.Copy

'...and paste it ito Word (in the correct way)
appWD.Selection.Paste

'Ask the user for a projectnumber, set a jump point in case the answer is empty
Help:
ProjectNumber = InputBox("Bitte Projektnummer eingeben:", "ExportRTF Frage")
If ProjectNumber = "" Then GoTo Help

If Cells(1, 1) = "P&I No." Or Cells(1, 1) = "R&I Buchstabe" Then
        IsPandI = True
        Suffix = "_Mit_R&I"
    Else
        IsPandI = False
        Suffix = "_Ohne_R&I"
    End If

'Build the filename and show the user
NameOfFile = "G:\Home\" & CurrentUser & "\desktop.ileaf\" & ProjectNumber & Suffix & ".rtf"
MsgBox "Aktuelle Tabelle wird als " & NameOfFile & " gespeichert."

'Save the document in the correct place
With WordDoc
    .SaveAs FileName:=NameOfFile, FileFormat:= _
        wdFormatRTF, LockComments:=False, Password:="", AddToRecentFiles:=True, _
        WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
         SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
        False
    .Close
End With

'Muahahaha kill word and wrap up loose ends
appWD.Quit

Set WordDoc = Nothing
Set appWD = Nothing
 
End Sub

Now the problem I have is that when I run this macro, the resulting
RTF document needs to be repaired if I open it in Word again and try to "save as" ("data integrity error (type 4) 1". However, if I do exactly the same actions as in the macro by hand and select "Save as" from the file menu in Word, the file saves perfectly without needing repair.
Could somebody please tell me how to fix this?

Thank you very much for your time and any help you can give me!

John

Hello John,

There are 2 problems I see with the macro which are marked in red below. If the worksheet exists, you're setting the variable to nothing. When running the code manually, this sheet is probably already active and your next statement Cells(1, 1).Select works.

'Test to see if a Worksheet is open'.
On Error Resume Next
Set wsheet = Sheets("Tabelle1")
   If wsheet Is Nothing Then 'Doesn't exist
        MsgBox "Das Macro kann ohne Tabelle nicht ausgeführt werden!", vbCritical, "ExportPDF Error"
            Set wsheet = Nothing
            Exit Sub
        Else 'Does exist
            Set wsheet = Nothing
            On Error GoTo 0
   End If

'Reset cursor position on worksheet
Cells(1, 1).Select

Try making these changes and rerunning the macro...

'Test to see if a Worksheet is open'.
On Error Resume Next
Set wsheet = Sheets("Tabelle1")
   If wsheet Is Nothing Then 'Doesn't exist
        MsgBox "Das Macro kann ohne Tabelle nicht ausgeführt werden!", vbCritical, "ExportPDF Error"
            Set wsheet = Nothing
            Exit Sub
   End If
On Error GoTo 0

'Reset cursor position on worksheet
wSheet.Cells(1, 1).Select

Sincerely,
Leith Ross