Forumbeitrag
Excel-Version des Fragestellers:
365 Business
Erfahrungslevel des Fragestellers:
Excel gut - VBA bescheiden
Hi Case,
ich glaube ich check es nicht. Ich habe hier einen Beitrag "Thema: Prüfen, ob Arbeitsmappe geöffnet und wenn nein, öffnen" gefunden das mein Problem lösen könnte, aber so ganz kann ich es nicht umsetzen. Im Makro wird geprüft ob die Datei offen ist. Wenn die Datei nicht offen ist läuft das Makro durch. Wenn die Datei offen ist hängt es sich auf ohne Meldung.
Der unten abgebildete Code ist ohne den Kopiervorgang von Word in Excel, weil dieser glaube ich nicht mein Problem ist. Kann mir bitte wer sagen was ich falsch gemacht habe? Bestimmt einiges. Ich habe es nach besten wissen versucht :-/
Sub DatenKopieren()
Dim xlApp As Object 'Excel.Application
Dim xlMappe As Object 'Excel.Workbook
Dim xlBlatt As Object 'Excel.Worksheet
Dim wdDocument As Document
Dim rngTable As Range
Dim wbOpen, As String
wbOpen = "Arbeitsdokument.xlsm"
If WkbExists( "Arbeitsdokument.xlsm") = False Then
If Dir(Folder) = "" Then
MsgBox "Datei " & Folder & " wurde nicht gefunden!"
Else
Application.ScreenUpdating = False
'Set Document verwende ich um die Infos aus einer Word Tabelle in Excel zu schieben
Set wdDocument = ActiveDocument
Set rngTable = wdDocument.Tables(1).Cell(1, 2).Range
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
xlApp.ScreenUpdating = False
Set xlMappe = xlApp.Workbooks.Open(Folder)
Set xlBlatt = xlMappe.Sheets("Tabelle1")
With xlBlatt
'Informationen kopieren
End With
xlMappe.Close SaveChanges:=True
Set xlBlatt = Nothing
Set xlMappe = Nothing
xlApp.Application.Quit
Set xlApp = Nothing
Application.ScreenUpdating = True
End If
Else
Application.ScreenUpdating = False
Workbooks(Folder).Activate
Set wdDocument = ActiveDocument
Set rngTable = wdDocument.Tables(1).Cell(1, 2).Range
Set xlApp = CreateObject("Excel.Application")
xlApp.ScreenUpdating = False
Set xlMappe = Workbooks(Folder)
Set xlBlatt = xlMappe.Sheets("Tabelle1")
With xlBlatt
'Informationen kopieren
End With
xlMappe.Close SaveChanges:=True
Set xlBlatt = Nothing
Set xlMappe = Nothing
Set xlApp = Nothing
Application.ScreenUpdating = True
End If
End Sub
'Function aus dem Forum
Private Function WkbExists(sPath As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sPath)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function