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

roll4ever · 2. August 2012

Hallo alle Helfenden, hallo Sepp,

ich habe meinen Code noch etwas erweitert und ein weiteres Makro eingebaut, sowie ein Calculate eingefügt. Ich bekomme zwar immernoch die unten angehängete Fehlermeldung, Excel stürzt aber auch nach mehrmaligem Durchlauf nicht mehr ab. Wenn ich einfch nur die auskommentierte Pause verwenden, stürzt mir Excel wieder ab.
Code:

Private Sub Zellen_sperren_entsperren()

'########################
'falls ein Fehler auftritt gehe zur Fehlerbehandlung
On Error GoTo ErrHandler
'########################

Dim NewWB As Object 'neu erstelltes Workbook mit Sheet("Wickelprotokoll")
Dim existierendesWB As Object 'das eventuell unter dem Pfad mit gleichem Dateinamen schon befindliche Workbook
Dim Continue As Boolean
Dim Schalter As Button
Dim Pfad As String 'Pfad zum Verzeichnis
Dim Dateiname As String 'Dateiname
Dim Dateiendung As String
Dim Dateiformat As Long
Dim Calc As Long
Dim wsPf As Worksheet
Set wsPf = Worksheets("Pfad")
Dim wsWi As Worksheet
Set wsWi = Worksheets("Wickelauftrag")
Dim wsWp As Worksheet
Set wsWp = Worksheets("Wickelprotokoll")

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

With wsWp

LetzteSpalte = .Cells(34, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(14, 1), .Cells(65536, LetzteSpalte)).Interior.ColorIndex = xlNone 'entfärbt sämtliche Zellen im Wickelprotokoll
.Range(.Cells(14, 1), .Cells(65536, LetzteSpalte)).Locked = True 'setzt alle Zellen auf "Gesperrt"

'färbt alle Spalten in denen die Wickler Werte eintragen müssen ROT und
'entsperrt die Bereiche in denen die Wickler Werte eintragen müssen
Spindelanzahl = .Range("C19").Value
LetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(LetzteZeile + 1, 3).Value "" Then 'Hybridband
LetzteZeile = LetzteZeile + 1
End If

.Range(.Cells(37, 6), .Cells(LetzteZeile, 7)).Interior.ColorIndex = 22 'Spalten "F" und "G"
.Range(.Cells(37, 6), .Cells(LetzteZeile, 7)).Locked = False

.Range(.Cells(37, 18), .Cells(LetzteZeile, 19 + Spindelanzahl - 1)).Interior.ColorIndex = 22 'Spalten "R" bis "S" + Spindelanzahl - 1
.Range(.Cells(37, 18), .Cells(LetzteZeile, 19 + Spindelanzahl - 1)).Locked = False

.Range(.Cells(37, 21 + Spindelanzahl - 1), .Cells(LetzteZeile, 21 + Spindelanzahl - 1)).Interior.ColorIndex = 22 'Spalte "U" + Spindelanzahl - 1
.Range(.Cells(37, 21 + Spindelanzahl - 1), .Cells(LetzteZeile, 21 + Spindelanzahl - 1)).Locked = False

.Range(.Cells(37, 23 + Spindelanzahl - 1), .Cells(LetzteZeile, 26 + Spindelanzahl - 1)).Interior.ColorIndex = 22 'Spalte "W" + Spindelanzahl - 1 bis "Z" .Range(.Cells(37, 21 + Spindelanzahl - 1), .Cells(LetzteZeile, 21 + Spindelanzahl - 1)).Interior.ColorIndex = 22 'Spalte "U" + Spindelanzahl - 1
.Range(.Cells(37, 23 + Spindelanzahl - 1), .Cells(LetzteZeile, 26 + Spindelanzahl - 1)).Locked = False

LetzteZeile = .Cells(.Rows.Count, LetzteSpalte).End(xlUp).Row
.Range(.Cells(LetzteZeile + 4, 20), .Cells(LetzteZeile + 23, 20)).Interior.ColorIndex = 22 'Spalte "T" in "Harzverbrauch gesamt"
.Range(.Cells(LetzteZeile + 4, 20), .Cells(LetzteZeile + 23, 20)).Locked = False

'färbt alle Spalten aus denen die Wickler Werte in IFS übernehmen müssen GRÜN
.Range(.Cells(LetzteZeile + 4, 2), .Cells(LetzteZeile + 23, 5)).Interior.ColorIndex = 35
.Range(.Cells(LetzteZeile + 4, 7), .Cells(LetzteZeile + 23, 12)).Interior.ColorIndex = 35

'färbt Zellen im Kopf des Wickelauftrags/Wickelprotokolls auf die geachtet werden sollte GELB
.Range("C18:C19,M15:M16,I18,C25,C26,L25,L26,L24,K22,A28,K28,Q18").Interior.ColorIndex = 6
If .Range("K23").Value "" Then .Range("K23").Interior.ColorIndex = 6

'löscht Buttons die von den Wicklern nicht benötigt werden
For Each Schalter In wsWp.Buttons
If Schalter.Name "Mengen_berechnen" And Schalter.Name "Wickelprotokoll_speichern" Then Schalter.Delete
Next Schalter

'Pfad zum Verzeichnis einlesen
'Pfad = wspf.Range("A25").Value
Pfad = .Range("T3").Value

End With

getDateiendungundDateiformat NewWB, Dateiendung, Dateiformat 'Dateierweiterung und Dateiformat ermitteln
Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\")

If Dir(Pfad & Dateiname & Dateiendung, vbNormal) "" Then 'wenn Datei schon vorhanden
Set existierendesWB = Workbooks.Open(Pfad & Dateiname) 'öffnen
If existierendesWB.Sheets("Wickelprotokoll").Range("Kontrollfeld_speichern").Value = 1 Then 'wenn = 1, dann nicht überschreiben
existierendesWB.Close False
Continue = False
Kill Pfad & Dateiname 'löschen
End If
Else
Continue = True
End If

If Continue Then 'wenn fortfahren
For i = 1 To 2
Dateiname = wsWi.Range("T4").Value & "_" & i
ThisWorkbook.Sheets("Wickelprotokoll").Copy 'Tabellenblatt "Wickelprotokoll" verschieben
Set NewWB = ActiveWorkbook
With NewWB
.Sheets(1).Protect "test"
.SaveAs Pfad & Dateiname & Dateiendung, FileFormat:=Dateiformat 'Datei speichern
' .Close 'Datei "Wickelprotokoll" schließen
End With

Call WriteMakro

With NewWB
.Save
.Close 'Datei "Wickelprotokoll" schließen
End With
Next i
End If

Calculate
'Application.Wait Now + TimeSerial(0, 0, 1)

With ThisWorkbook
.Sheets("Wickelprotokoll").Delete
.Sheets("Wickelauftrag").Activate
End With

'########################
ErrHandler:

With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "Zellen_sperren_entsperren" & 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 - Online_Wickelprotokoll"
.Clear
End If
End With

On Error GoTo 0
'########################

With Application
.EnableEvents = True
.Calculation = Calc
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.ScreenUpdating = True
End With

Set NewWB = Nothing

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Das Ergebnis ist also nicht ganz befriedigend, aber ein Fortschritt!

Vielen Dank für deine Hilfe Sepp!!!
Ohne dich wäre ich nicht so weit gekommen!!!

Ich habe noch einiges zu tun an dem Code, deswegen würde ich das Thema noch offen lassen.

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

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

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

Neues Workbook öffnen, Worksheet rein kopieren.... - Similar Threads - Workbook öffnen Worksheet

Workbook ohne Makros starten

Workbook über variablen Pfad öffnen

Einträge aus Zellen aus einem anderen Workbook einlesen

Workbook öffnen und umbenennen

Warten, bis Workbook geöffnet

Workbook öffnen / Worksheet aktivieren

Workbook öffnen/aktivieren mit VBA/VBS