Office: Neues Workbook öffnen, Worksheet rein kopieren....

Hallo!

Ich habe gestern die gleiche/ leicht veränderte Frage gestellt und darauf von Chris auch eine Antwort

bekommen.

Leider schaffe ich es nicht das ganze auf mein mittlerweile erweitertes Problem zu erweitern *upps.

Mein Plan ist folgender:
Ich habe ein Workbook(XYZ) das einen beliebigen Namen haben kann. In diesem Workbook gibt es unter anderem ein Worksheet(Protokoll), dass ich in ein neues Workbook(New) kopieren will und in dem alten Workbook(XYZ) löschen will. In dem neuen Workbook(New) soll jetzt nur das Worksheet(Protokoll) vorhanden sein.
Das Workbook(New) soll jetzt in einem Ordner gespeichert. Der Pfad befindet sich in dem String "Pfad", der Dateiname in dem String "Dateiname".
Befindet sich an der angegebenen Stelle nun schon eine Datei (auch .xls) mit dem gleichen Namen, muss diese geöffnet werden, eine Zelle in ihr auf einen Wert überprüft werden und dann ggf. überschrieben, oder der Vorgang abgebrochen werden.

Das ganze ist im Moment für meinen Wissensstand noch zu hoch, aber ich denke das ich das mit eurer Hilfe hinbekommen kann *wink.gif*.

Vielen Dank für die (wahrscheinlich) große Mühe!

Gruß,
roll4ever

P.S. Ich hoffe das Ganze ist halbwegs verständlich!

:)

 

Hallo ?,

soweit ich das verstanden habe und anhand deiner Infos, sollte das ungefähr so laufen.

Sub protokoll()
Dim objWB As Workbook
Dim strPath As String, strFileName As String
Dim boolContinue As Boolean
Dim lngCalc As Long

On Error GoTo ErrExit

With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With

strPath = "E:\Forum" 'Verzeichnis

strFileName = "Test.xls" 'Dateiname

strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")

If Dir(strPath & strFileName, vbNormal) <> "" Then 'wenn Datei schon vorhanden
Set objWB = Workbooks.Open(strPath & strFileName) 'öffnen
If objWB.Sheets("Tabelle1").Range("A1") = 1 Then 'wenn Wert in A1 = 1
objWB.Close False 'schließen
boolContinue = True
Kill strPath & strFileName 'löschen
End If
Else
boolContinue = True
End If

If boolContinue Then 'wenn fortfahren
ThisWorkbook.Sheets("Protokoll").Move 'Tabelle 'Protokoll' verschieben
ActiveWorkbook.SaveAs strPath & strFileName, FileFormat:=56 'Datei speichern
ActiveWorkbook.Close 'Datei schließen
End If

ErrExit:

With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'protokoll'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With

On Error GoTo 0

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With

Set objWB = Nothing
End Sub





« Gruß Sepp »

 

Hallo Sepp,

vielen Dank für die Antwort!
*Smilie
Werde das ganze heute mal ausprobieren und Feedback geben!

Viele Grüße,

roll4ever

 

Hallo Sepp,

der Code läuft soweit ganz gut, allerdings bekomme ich beim speichern die Fehlermeldung 1004 Die Methode 'Save As' für das Objekt '_Worksheet' ist fehlgeschlagen.

Das ganze habe ich jetzt mit folgendem im Netz gefundenen Code versucht zu umgehen:
Code:

Allerdings hängt sich Excel jetzt immer auf! Wo liegt da der Fehler?

Außerdem will ich das verschobene Worksheet("Wickelprotokoll") mit einem Passwort versehen:
Code:

auch das klappt nicht!

Vielen Dank für die Hilfe!!!

Gruß,
roll4ever

 

Hallo ??,

poste bitte immer den gesamten Code, im ersten With-Rahmen fehlt der Beginn, siehe Code.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub protokoll()
Dim objWB As Workbook
Dim strPath As String, strFileName As String
Dim strExt As String, lngF As Long
Dim boolContinue As Boolean
Dim lngCalc As Long

On Error GoTo ErrExit

With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With

'Achtung!
With Sheets("?") 'Tabellenname unbekannt!
'Pfad zum Verzeichnis einlesen
Pfad = .Range("T3").Text
Dateiname = .Range("T4").Text
End With


strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")

If Dir(strPath & strFileName, vbNormal) <> "" Then 'wenn Datei schon vorhanden
Set objWB = Workbooks.Open(strPath & strFileName) 'öffnen
If objWB.Sheets("Tabelle1").Range("A1") = 1 Then 'wenn Wert in A1 = 1
objWB.Close False 'schließen
boolContinue = True
Kill strPath & strFileName 'löschen
End If
Else
boolContinue = True
End If

If boolContinue Then 'wenn fortfahren
ThisWorkbook.Sheets("Wickelprotokoll").Move 'Tabelle 'Protokoll' verschieben
Set objWB = ActiveWorkbook
getFileExtAndFormat objWB, strExt, lngF 'Dateierweiterung und Format ermitteln
With objWB
.Sheets(1).Protect "test"
.SaveAs strPath & strFileName & strExt, FileFormat:=lngF 'Datei speichern
.Close 'Datei schließen
End With
End If

ErrExit:

With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'protokoll'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With

On Error GoTo 0

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With

Set objWB = Nothing
End Sub

Private Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
With WB
If Val(Application.Version) < 12 Then
strExt = ".xls": lngFormat = -4143
Else
Select Case WB.FileFormat
Case 51: strExt = ".xlsx": lngFormat = 51
Case 52:
If .HasVBProject Then
strExt = ".xlsm": lngFormat = 52
Else
strExt = ".xlsx": lngFormat = 51
End If
Case 56: strExt = ".xls": lngFormat = 56
Case Else: strExt = ".xlsb": lngFormat = 50
End Select
End If
End With
End Function





« Gruß Sepp »

 

Hallo Sepp,

vielen Dank für deine Hilfe.

Ich kann deinen Code leider nicht vollständig testen, da mein Excel immer an der Stelle
Code:

den Geist aufgibt und sich selbst beendet. Ich verwende Excel2003, falls das weiterhilft.

Bin ein bißchen am Verzweifeln!!!*mad.gif*

Grüße,
roll4ever

 

Hallo,

eine weitere Anmerkung. Wenn ich den Code Zeilenweise durchgehe kriege ich an besagter Stelle immer die Meldung:

Wechsel in den Haltemodus ist zu diesem Zeitpunkt nicht möglich.

Ich schätze das das etwas mit dem Kopieren zu tun hat, da man dabei ja nicht stoppen kann. Aber vielleicht hilft es ja irgendjemandem sonst weiter!

Gruß,
roll4ever

 

Hallo ???, (verschweigst ganz schön hartnäckig deinen Namen!)


sorry, ein Lapsus meinerseits, es muss statt .Move natürlich .Copy heißen.



« Gruß Sepp »

 

Hallo Sepp,

vielen Dank für die Info.

Setze es dann mal gleich um und hoffe auf keine neuen Schwierigkeiten!!

Vielen Dank und mit ziemlicher Sicherheit bis bald,

Claas *grins

Schöne Woche noch!!!

 

Hallo Sepp und natürlich auch alle anderen!

Wie gestern angekündigt ist hier schon meine nächste Frage:

Ich habe meinen Code um Folgende Zeilen erweitert:
Code:

und habe jetzt wieder das Problem, dass Excel an der entsprechenden Stelle abstürzt. Öffnen ich die Datei nun mit Wiederherstell-Funktion ist das Sheet("Wickelprotokoll") gelöscht und das Sheet("Wickelauftrag") aktiv, so wie ich es wollte.

Woran kann denn diese nervige Abstürzerei liegen?
Ohne die Codezeilen läuft das Makro sauber durch.

Vielen Dank für eure Hilfe!!

 

Hallo Claas,

ohne Punkte ist der With-Rahmen sinnlos!


Versuche es so.

« Gruß Sepp »

 

Hallo Sepp,

Vielen Dank für den Tipp.
Jetzt scheint Excel nicht mehr abzustürzen, ich bekomme allerdings an der Stelle:
Code:

die angehängte Fehlermeldung aus.

Kannst du mir da auch weiterhelfen? Habe im Netz noch keine passende Beschreibung oder Lösung zur Fehlermeldung 40040 gefunden.

 

Hallo Sepp,

ich glaube mittlerweile nicht mehr das es an den im vorigen Beitrag beschriebenen Zellen liegt *frown.gif* . Allerdings weiß ich auch nicht wo sonst. Was bräuchtest du/ihr denn um eventuell gezielter zu helfen?

Vielen Dank für die Anstrengungen!

 

Hallo Claas,

"Was bräuchtest du/ihr denn um eventuell gezielter zu helfen?"

Du solltest den gesamten Code posten und nicht nur Fragmente!

Was zur Hölle ist z.B. "Zellen_sperren_entsperren" ?


« Gruß Sepp »

 

Hallo Sepp,

hier der gesamte Code:

Code:

Das Sub wird aus:
Code:

durch drücken eines Buttons aufgerufen.

Vielen Dank für dein Angagement obwohl es mit mir doch recht zäh voran geht.*eek.gif*