Hi, folgender Fehler erscheint bei ( Set Datei = Workbooks.Open(Dateiname) )
Fehler:"die methode open für das objekt workbooks ist fehlgeschlagen"
Habe schon viel gelesen aber nichts brachte den Erfolg, hoffe ihr habt eine Idee oder besser eine Lösung ^^
Code: |
Option Explicit
Sub Upgrade()
Dim Dateiname As String
Dim Datei As Object
Dim Msg As Byte
'On Error GoTo ENDE
Msg = MsgBox("Bitte wählen Sie die Datei aus welche Ihre Daten enthält!", vbInformation, "Upgrade")
Anfang:
Dateiname = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xlsm), *.xlsm", Title:="Alten Expeditionsrechner wählen!") ' Datei auswählen
If Dateiname Like ThisWorkbook.FullName Then Msg = MsgBox("Sie haben die gleiche Datei gewählt!", vbCritical, "Falsche Datei"): GoTo Anfang ' bei Auswahl gleicher Datei
If Dateiname = "Falsch" Then Msg = MsgBox("Der Upgrade vorgang wurde abgebrochen!", vbInformation, "Information"): Exit Sub ' bei Abbruch
Application.ScreenUpdating = False
Set Datei = Workbooks.Open(Dateiname) ' Datei öffnen
' Daten kopieren
Datei.Worksheets("Auswertungen").Range("AB2").Copy Destination:=ThisWorkbook.Worksheets("Auswertungen").Range("AB2")
Datei.Worksheets("Auswertungen").Range("AB7:AB16").Copy Destination:=ThisWorkbook.Worksheets("Auswertungen").Range("AB7:AB16")
Datei.Worksheets("Auswertungen").Range("AA19").Copy Destination:=ThisWorkbook.Worksheets("Auswertungen").Range("AA19")
Datei.Worksheets("Auswertungen").Range("AC25").Copy Destination:=ThisWorkbook.Worksheets("Auswertungen").Range("AC25")
Datei.Worksheets("Auswertungen").Range("AC27:AC30").Copy Destination:=ThisWorkbook.Worksheets("Auswertungen").Range("AC27:AC30")
Datei.Worksheets("Auswertungen").Range("AC33:AC34").Copy Destination:=ThisWorkbook.Worksheets("Auswertungen").Range("AC33:AC34")
Datei.Worksheets("Auswertungen").Range("AC36").Copy Destination:=ThisWorkbook.Worksheets("Auswertungen").Range("AC36")
Datei.Worksheets("Auswertungen").Range("AB37:AB39").Copy Destination:=ThisWorkbook.Worksheets("Auswertungen").Range("AB37:AB39")
Datei.Worksheets("Auswertungen").Range("AB45:AD49").Copy Destination:=ThisWorkbook.Worksheets("Auswertungen").Range("AB45:AD49")
Datei.Close ' Datei schließen
Application.ScreenUpdating = True
Msg = MsgBox("Die Daten wurden übertragen!", vbInformation, "Erfolgreiche Übertragung") ' Msg bei Erfolg
' Bei Fehler
ENDE:
Msg = MsgBox("Es ist ein fehler aufgetreten!", vbCritical, "Übertragung fehlgeschlagen"): MsgBox (Error)
End Sub |
Habe es schon mal woanders versuch aber bisher ohne erfolg!
http://www.office-loesung.de/ftopic635394_0_0_asc.php
|