Word-Makro startes aus Excel nicht
29.05.2018 07:16:17
Frank
ich hab seid gestern das Problem das mein Word-Makro nicht mehr aus Excel startet, aus Word aber schon.
Zuvor ging alles bestens und ich bin mir eigentlich sicher dass ich am Aufruf nichts verändert habe.
Fehler beim Aufruf: Das angegebene Makro kann nicht ausgeführt werden.
Wer kann helfen, ich steh mit beiden Füßen auf dem Schlauch :-(
Code in Excel:
Sub WordStarten(Typ)
Dim objWord As Object
Dim objDoc As Object
On Error Resume Next
Set objWord = GetObject(, "Word.Application") 'Bereits laufende Wordinstanz an Variable ü _
bergeben
On Error GoTo 0 'Laufzeitfehler wieder auslösen
If objWord Is Nothing Then 'Wenn keine bereits laufende Wordinstanz gefunden ...
Set objWord = CreateObject("Word.Application") '... Word neu starten und neue Instanz an _
Variable übergeben
End If
'objWord.Visible = False 'Worddokument nicht sichtbar machen
MsgBox "Der Aufgabensatz wird im Hintergrund erstellt.", vbOKOnly + vbInformation, " _
Aufgabensatz erstellen"
'Variable übergeben
Set objDoc = objWord.documents.Open("H:\Eigene Dateien\Neu.docm")
objWord.Run "PrüfungErstellen" & Typ
MsgBox "Zu Word wechseln" & vbLf & "Datei bitte ""Speichern unter"" und beim schließen ""Nicht _
_
_
Speichern !""", , "Aufgabensatz wurde erstellt", vbInformation
objWord.Visible = True
Set objWord = Nothing
End Sub
Und Code in Word:
Sub PrüfungErstellen(Typ)
'Erstellen des Prüfungssatzes
Dim apExcel As Excel.Application
Dim wbExcel As Excel.Workbook
Dim wsExcel As Excel.Worksheet
Dim rgExcel As Excel.Range
Dim rgZeile As Excel.Range
Dim Datei As Document
Dim xlZeile As Long
Dim Pfad, Doc, DocDateA, DocDateF As String
Dim Auf As Integer
On Error Resume Next
Set apExcel = Excel.Application
Set wbExcel = apExcel.Workbooks.Open("H:\Eigene Dateien\Aufgabenübersicht.xlsm", , , , , , , , , _
_
_
_
_
, , , False) 'ThisDocument.Path & ""H:\ _
_
Eigene Dateien\EFK Prüfung\Übungsaufgaben
Set wsExcel = wbExcel.Worksheets(Typ)
Pfad = "H:\Eigene Dateien\EFK Prüfung\EFK-Fragenkatalog\"
On Error GoTo Fehler
With wsExcel
i = 2
Do Until .Cells(i, 1).Value = ""
If .Cells(i, 12).Value = "" Then GoTo weiter 'Aufgabe nicht ausgewählt
Doc = Pfad & .Cells(i, 1).Value 'Dateiname
Auf = .Cells(i, 2).Value 'Aufgabe
Documents.Open FileName:=Doc, ReadOnly:=True
ActiveDocument.Tables(Auf).Select
Selection.Copy
Documents("Neu.docm").Activate
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.TypeParagraph
Documents(Doc).Close (wdDoNotSaveChanges)
weiter:
i = i + 1
Loop
End With
Fehler:
wbExcel.Close SaveChanges:=False
Set apExcel = Nothing
Set wbExcel = Nothing
Set wsExcel = Nothing
Set rgExcel = Nothing
End Sub