1. Sub AnschreibenGutachtenNeu()
  2. Dim strFileName As String
  3. Dim objWDApp As Object 'Word.Application
  4. Dim objDocx As Object 'Word.Document
  5. Dim currentrow As Byte 'Referenzzelle in Excel ( Weiß nicht ob das als Byte Wert Funktioniert )
  6. strFileName = "C:\Users\CG\Documents\Spaces\Bea und Chris\Projekt Makro\tester.docx"
  7. If Dir(strFileName) = "" Then
  8. MsgBox "Datei """ & strFileName & """ nicht gefunden!"
  9. Exit Sub
  10. End If
  11. currentrow = ActiveCell.Row
  12. Application.ScreenUpdating = False
  13. If objWDApp Is Nothing Then
  14. 'damit wird verhindert das Word ein zweites Mal
  15. 'mit CreateObject geöffnet wird
  16. 'die erstere läst sich sonst aus dem Task nicht entfernen
  17. 'Bei mehreren Versuchen erreichst du ganz schnell ein OutOfMemory
  18. Set objWDApp = CreateObject("Word.Application")
  19. bolWordLiefNicht = True
  20. End If
  21. 'Word-Anwendung sichtbar starten
  22. Set objWDApp = CreateObject("Word.Application")
  23. objWDApp.Visible = True
  24. 'Vorlage öffnen - schreibgeschützt
  25. Set objDocx = objWDApp.Documents.Open(strFileName, ReadOnly:=True)
  26. 'Werte aus Zellen in Excel an Textmarken im Worddokument einfügen
  27. If objDocx.Bookmarks.Exists("Aktenzeichen") = True Then
  28. objDocx.Bookmarks("Aktenzeichen").Range.Text = Cells(currentrow, "G") 'aus Spalte G
  29. End If
  30. Application.ScreenUpdating = True
  31. objDocx.SaveAs ("C:\Users\CG\Documents\Spaces\Bea und Chris\Projekt Makro\ErsterSpeicher.docx")
  32. End Sub

Please Help Me