Meldung: Excel funktioniert nicht mehr!
11.01.2016 13:54:40
Walter
würde mich über Unterstützung freuen, da ich das Problem nicht erkenne.
Die folgende Prozedur soll in eine vorhanden Datei ein Tabellenblatt aus einer anderen Datei importieren und anschließend aus einem benachbarten Tabellenblatt die Shapes kopieren und Makros zuweisen.
Das funktioniert soweit auch gut. Bis zu dem Punkt an dem ich "wksZiel2.Delete" ausführe. Der Worksheet wird ordnungsgemäß gelöscht aber beim schließen der Datei kommt die Meldung "Excel funktioniert nicht mehr richtig und muss beendet werden".
Liegt das vielleicht an den kopierten shapes das es noch einen Bezug zu "wksZiel2" gibt,aus dem sie kopiert wurden?
Hätte jemand eine Idee an was es liegt?
Danke und Gruß
Walter
Sub DatenImportieren()
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Dim wksZiel2 As Worksheet
Dim strPath1 As String
Dim strPath2 As String
strPath1 = "MeinPfad1"
strPath2 = "MeinPfad2"
Set wksQuelle = Workbooks.Open(FileName:=strPath1 & "MeineDatei.xlsx").Worksheets("Tabelle1" _
_
)
Set wksZiel = ThisWorkbook.Worksheets("Tabelle1")
ThisWorkbook.SaveCopyAs strPath2 & ThisWorkbook.Name
wksZiel.Activate
wksZiel.Copy before:=Sheets(1)
Set wksZiel2 = ThisWorkbook.Worksheets("Tabelle1 (2)")
Application.DisplayAlerts = False
wksZiel.Delete
Set wksZiel = Nothing
Application.DisplayAlerts = True
wksQuelle.Copy before:=Worksheets(1)
wksQuelle.Parent.Close
Set wksQuelle = Nothing
wksZiel2.Activate
ActiveSheet.Shapes.Range(Array("Oval 1", "Oval 2", "Oval 3", "Oval 4")).Select
Selection.Copy
Worksheets("Tabell1").Activate
Range("J2").Select
ActiveSheet.Paste
Range("A2").Select
ActiveSheet.Shapes.Range(Array("Oval 1")).Select
Selection.OnAction = "Makro1"
ActiveSheet.Shapes.Range(Array("Oval 2")).Select
Selection.OnAction = "Makro2"
ActiveSheet.Shapes.Range(Array("Oval 3")).Select
Selection.OnAction = "Makro3"
ActiveSheet.Shapes.Range(Array("Oval 4")).Select
Selection.OnAction = "Makro4"
Range("A2").Select
Application.DisplayAlerts = False
wksZiel2.Delete
Application.DisplayAlerts = True
Set wksZiel2 = Nothing
ThisWorkbook.Save
End Sub
Anzeige