Foutmelding 4605, VBA Excel publiceren in Word

Question

In een Excel bestand hebben wij alle omzetten van onze ruim 250 klanten staan.

Nu hebben we het zover dat voor elke relatie een Word bestand gemaakt wordt met allen omzetten gecategoriseerd per onderdeel.

Als ik de onderdelen van de macro's los draai werkt alles perfect.

Bij het publiceren naar Word krijg ik de volgende melding:

Fout 4605 tijdens uitvoering:

Deze methode of eigenschap is niet beschikbaar omdat het Klembord leeg of ongeldig is.

De fout komt pas naar ca. 100 Word-bestanden te hebben aangemaakt naar boven.

---

Macro opslaan als WORD:

Sub SaveasWORD()

Sheets("Publicatieblad").Activate

Dim ws As Worksheet

Set ws = ActiveSheet

Dim Bestandsnaam As String

Dim Sysdate

Bestandsnaam = ActiveSheet.Range("C3").Value

Sysdate = Format(Date, "yyyymmdd")

Dim objWd As Object

Set objWd = CreateObject("word.application")

objWd.Visible = False

Dim objDoc As Object

Set objDoc = objWd.Documents.Add

objDoc.PageSetup.Orientation = 1 '  portrait = 0

Application.ScreenUpdating = False

ws.UsedRange.Copy

objDoc.Content.Paste

Application.CutCopyMode = False

Application.DisplayAlerts = False

objDoc.SaveAs ("E:\Klantengesprekken\Publicaties20161116" & Bestandsnaam & "-" & Sysdate & ".docx")

Application.DisplayAlerts = True

Application.ScreenUpdating = True

Application.CutCopyMode = False

End Sub

---

Overall macro:

Sub Relatiegegevens0word()

'

' Relatiegegevens0word Macro

'

'

    Sheets("Klantendatabase").Activate

    Range("A2").Select

    Dim cll As Range

    Dim rng As Range

    Set rng = Range("A2:A265")

    For Each cll In rng

    cll.Copy

    ''' was

    '''Range(A, "cll.ROW").Select

    ''Selection.Copy

    ''' now

    Cells(cll.Row, "A").Copy

    ''' was

    ''' Sheets("Publicatieblad").Select

    ''' is

    Sheets("Publicatieblad").Activate

    Range("C6").Select

    ActiveSheet.Paste

    Sheets("Klantendatabase").Select

    Application.CutCopyMode = False

    Application.DisplayAlerts = False

    Application.Run "'Klantengesprekken.xlsm'!SaveasWORD"

    Sheets("Klantendatabase").Activate

    Next cll

End Sub

---

Ook als we de klantenrapporten openen in Word (die net zijn aangemaakt door de Macro) de melding dat deze al in gebruik is.

Waarschijnlijk is het een kleine aanpassing, maar wij komen er niet uit.

Answer 1

Mayckel,

Zo te zien open je Word bij elke rondgang door de lus, dat zou betekenen dat er nogal wat Word-instanties worden geopend.

Daarbij komt dat je elke keer een nieuw document opent zonder dat te sluiten.

Als je de code zo eens probeert, gaat het dan beter?

Sub SaveasWORD(objWd As Object)

    Sheets("Publicatieblad").Activate

    Dim ws As Worksheet

    Dim objDoc As Object

    Set ws = ActiveSheet

    Dim Bestandsnaam As String

    Dim Sysdate

    Bestandsnaam = ws.Range("C3").Value

    Sysdate = Format(Date, "yyyymmdd")

    Set objDoc = objWd.Documents.Add

    objDoc.PageSetup.Orientation = 1 '  portrait = 0

    Application.ScreenUpdating = False

    ws.UsedRange.Copy

    objDoc.Content.Paste

    Application.CutCopyMode = False

    Application.DisplayAlerts = False

    objDoc.SaveAs ("E:\Klantengesprekken\Publicaties20161116" & Bestandsnaam & "-" & Sysdate & ".docx")

    objDoc.Close 0

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    Application.CutCopyMode = False

 End Sub

 Sub Relatiegegevens0word()

 '

 ' Relatiegegevens0word Macro

 '

 '

     Dim cll As Range

     Dim rng As Range

     Dim objWd As Object

     Sheets("Klantendatabase").Activate

     Range("A2").Select

     Set rng = Range("A2:A4")

     Set objWd = CreateObject("word.application")

     objWd.Visible = False

     For Each cll In rng

     cll.Copy

     ''' was

     '''Range(A, "cll.ROW").Select

     ''Selection.Copy

     ''' now

     Cells(cll.Row, "A").Copy

     ''' was

     ''' Sheets("Publicatieblad").Select

     ''' is

     Sheets("Publicatieblad").Activate

     Range("C6").Select

     ActiveSheet.Paste

     Sheets("Klantendatabase").Select

     Application.CutCopyMode = False

     Application.DisplayAlerts = False

     SaveasWORD objWd

     Sheets("Klantendatabase").Activate

     Next cll

     If Not objWd Is Nothing Then

        objWd.Quit 0

    End If

 End Sub

In de procedure Relatiegegevens0Word wordt nu voor de lus 1 instantie van Word geopend en na de lus wordt deze weer gesloten.

In de procedure SaveAsWord wordt steeds 1 document aangemaakt, gegevens worden geplakt en het document wordt opgeslagen en gesloten.

Overigens zou ik proberen te voorkomen dat worksheets elke keer geactiveerd/geselecteerd worden, dat werkt vertragend en is ook niet nodig.

Jan

Answer 2

Bedankt, het werkt perfect!