VBA Workbook_Open Laufzeitfehler 9
10.10.2017 09:57:33
Bernd
ich bin gerade ein wenig am Verzweifeln.
Ich habe ein Workbook_Open-Makro, dass beim automatischen Durchlauf immer wieder einen Laufzeitfehler 9 ausspuckt und mitten im Code abbricht. Leider bekomme ich nicht "debuggen" angezeigt, weiß also nicht, wo der Fehler genau entsteht. Erstmals aufgetreten ist er, als ich die Routine "format" eingebaut habe.
Wenn ich im Nachgang das Makro manuell mit F8/F5 laufen lasse, dann läuft es ohne Probleme und einwandfrei durch.
Kann mir bitte jemand einen Tipp geben, wie ich diesem Fehler auf die Schliche komme?
Private Sub Workbook_Open()
' Abfrage auf schreibgeschützt öffnen
If ThisWorkbook.ReadOnly = False Then
Dim check
check = MsgBox("Steuerungstool mit Schreibschutz öffen?", vbYesNo, "Bitte wählen Sie...")
Application.DisplayAlerts = False
With ThisWorkbook
If check = vbYes Then .ChangeFileAccess xlReadOnly
End With
Application.DisplayAlerts = True
End If
' Abfrage auf schreibgeschützt öffnen Ende
Set WB = ThisWorkbook
User = Application.UserName
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each ws In WB.Worksheets
ws.Visible = True
ws.Unprotect Password:=Passwort
If ws.Name = "Liste_Vertrieb" Then ws.Delete
Next ws
' Rohdaten aus Vertriebsliste ziehen
Set WB_roh = Workbooks.Open(Rohdaten)
WB_roh.Sheets(1).Copy after:=WB.Sheets(Sheets.Count)
WB_roh.Close False
Set WB_roh = Nothing
WB.Sheets(Sheets.Count).Name = "Liste_Vertrieb"
With Sheets("Liste_Vertrieb")
If .FilterMode Then .ShowAllData
End With
' Rohdaten aus Vertriebsliste ziehen Ende
' Vertriebsliste die Derivatenamen zuteilen
Call Derivat
' Vertriebsliste die Derivatenamen zuteilen Ende
' Auf Basis der Derivatenamen die Einträge in die Tabellenblätter umkopieren
Call Zuteilung
' Auf Basis der Derivatenamen die Einträge in die Tabellenblätter umkopieren Ende
' Formatierung
Call format
' Formatierung ENDE
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set WB = Nothing
Set ws = Nothing
End Sub
Sub Derivat()
Set ws = ThisWorkbook.Sheets("Liste_Vertrieb")
lz = ws.Cells(Rows.Count, 2).End(xlUp).Row
With ws
For i = 2 To lz
'' Derivate zuteilen
' Suche Derivat1
Set rngSuchbereich = .Cells(i, 3).Find(what:="GT", LookIn:=xlValues)
If rngSuchbereich Is Nothing Then
Else
.Cells(i, 2).Value = "Derivat1"
End If
' Suche Derivat2
Set rngSuchbereich = .Cells(i, 3).Find(what:="AT", LookIn:=xlValues)
If rngSuchbereich Is Nothing Then
Else
.Cells(i, 2).Value = "Derivat2"
End If
' Suche Derivat3
Set rngSuchbereich = .Cells(i, 3).Find(what:="BC", LookIn:=xlValues)
If rngSuchbereich Is Nothing Then
Else
.Cells(i, 2).Value = "Derivat3"
End If
' Suche Derivat4
Set rngSuchbereich = .Cells(i, 3).Find(what:="AB", LookIn:=xlValues)
If rngSuchbereich Is Nothing Then
Set rngSuchbereich = .Cells(i, 3).Find(what:="AC", LookIn:=xlValues)
If rngSuchbereich Is Nothing Then
Set rngSuchbereich = .Cells(i, 3).Find(what:="AD", LookIn:=xlValues)
If rngSuchbereich Is Nothing Then
Else
.Cells(i, 2).Value = "Derivat4"
End If
Else
.Cells(i, 2).Value = "Derivat4"
End If
Else
.Cells(i, 2).Value = "Derivat4"
End If
'' Derivate zuteilen Ende
Next i
Set rngSuchbereich = Nothing
End With
Set ws = Nothing
End Sub
Sub Zuteilung()
lz = ThisWorkbook.Sheets("Liste_Vertrieb").Cells(Rows.Count, 2).End(xlUp).Row
'' Einträge den Tabellenreitern der Derivate zuordnen
For i = 2 To lz
On Error Resume Next
With Sheets("Liste_Vertrieb")
Ordernummer = .Cells(i, 5).Value
Baureihe = .Cells(i, 2).Value
End With
With ThisWorkbook.Sheets(Baureihe)
If IsError(Application.Match(Ordernummer, .Columns(4), 0)) Then
lz1 = .Cells(Rows.Count, 2).End(xlUp).Row + 1
If lz1 "";$Z$3:" & Cells(3, ssp + 30).Address & ")"
Sheets(Baureihe).Cells(lz1, ssp + 33).Value = Date
' Dropdown für Produktionsstandort
With Sheets(Baureihe).Cells(lz1, 18).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="Standort1,Standort2"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
' Dropdown für Produktionsstandort Ende
' Dropdown für Schaltzentrum
With Sheets(Baureihe).Cells(lz1, 15).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="offen,bestellt,vorhanden"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
' Dropdown für Schaltzentrum Ende
End If
' Zeitkriterium der Datenübernahme 08/2016
End If
' Zeitkriterium der Datenübernahme 08/2016 Ende
End With
Next i
'' Einträge in Tabelle Ende
End Sub
Sub format()
Set ws = ThisWorkbook.Sheets("F48")
'' Bedingte Formatierung (jede zweite Zeile einfärben)
' For Each ws In ThisWorkbook.Worksheets
ws.Select
lz = ws.Cells(Rows.Count, 2).End(xlUp).Row
ssp = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Suche = "$A$4:" & ws.Cells(lz, ssp).Address
ws.Range(Suche).FormatConditions.Delete
With ws
.Range(Suche).FormatConditions.Add Type:=xlExpression, Formula1:= _
"=REST(ZEILE();2)=1"
Range(Suche).FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With ws.Range(Suche).FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
End With
.Range(Suche).FormatConditions(1).StopIfTrue = False
End With
'' Bedingte Formatierung (jede zweite Zeile einfärben) Ende
Set ws = Nothing
End Sub