PDA

Vollständige Version anzeigen : Excel reagiert nicht mehr


toby11
02.04.2012, 13:16
Hallo,

ich habe ein Modul innerhalb einer Excel-Datei ohne Probleme zum Laufen gebracht.
Dann habe ich auf eine bestimmte Tabelle "Einzel_Nachweis_gesamt" angeklickt. Plötzlich kommt die Meldung "Excel reagiert nicht mehr" und ich muss Excel neu starten.
Wenn ich jedoch auf andere Tabellen anklicke, bekomme ich keine Meldung und kann einwandfrei arbeiten.

Ich finde in meiner Code die Ursache jedoch nicht. Könnt ihr mir bitte dabei helfen?

Tobias

Hier ist der Code:
Sub Progressbar1()
Dim PctDone As Single
Static freifahrt_eintrag_fertig As Boolean
Dim datei_meisterschaften As String
Worksheets("Fahrten").Unprotect Password:="GBF#1"
Worksheets("Fahrtkosten_gesamt").Unprotect Password:="GBF#1"
Worksheets("Einzel_Nachweis_gesamt").Unprotect Password:="GBF#1"
Worksheets("End_Verwendungsnachweis").Unprotect Password:="GBF#1"

If Application.EnableEvents = True Then
Application.EnableEvents = False
End If

abschluss_flag = True

ret = MsgBox("Soll auch der Verwendungsnachweis erstellt werden?", vbYesNo, "Achtung")
If ret = vbNo Then
abschluss_flag = False
Else
sFile = "Überblick_Meisterschaften.xlsm"
sPath = ThisWorkbook.Path & "\" & sFile
If WkbExists("Überblick_Meisterschaften.xlsm") = False Then
' Datei "Überblick_Meisterschaften.xlsm" öffnen
Workbooks.Open sPath
End If

ende_tab_meister_tage = Workbooks("Überblick_Meisterschaften.xlsm").Worksheets("Tage").Cells(Rows.Count, 1).End(xlUp).Row + 1

sFile = "Übungsleiter.xlsm"
sPath = ThisWorkbook.Path & "\" & sFile
If WkbExists("Übungsleiter.xlsm") = False Then
' Datei "Übungsleiter.xlsm" öffnen
Workbooks.Open sPath
End If
End If

Workbooks("BGS-Fahrtkosten.xlsm").Activate
Worksheets("Fahrten").Select

ende_tabelle_db = Worksheets("DB").Cells(Rows.Count, 1).End(xlUp).Row + 1
ende_tabelle_meisterschaften = Worksheets("Meisterschaften").Cells(Rows.Count, 1).End(xlUp).Row + 1
ende_tabelle_fahrt = Worksheets("Fahrt").Cells(Rows.Count, 1).End(xlUp).Row + 1
ende_tabelle_fahrten = Worksheets("Fahrten").Cells(Rows.Count, 1).End(xlUp).Row + 1
ende_tabelle_fahrtkosten = Worksheets("Fahrtkosten").Cells(Rows.Count, 6).End(xlUp).Row + 1
ende_tabelle_fahrtkostengesamt = Worksheets("Fahrtkosten_gesamt").Cells(Rows.Count, 6).End(xlUp).Row + 1
ende_tabelle_einzelnachweis = Worksheets("Einzel_Nachweis").Cells(Rows.Count, 2).End(xlUp).Row + 1
ende_tabelle_einzelnachweisgesamt = Worksheets("Einzel_Nachweis_gesamt").Cells(Rows.Count, 2).End(xlUp).Row + 1
ende_tabelle_fahrten_save = Worksheets("Fahrten_save").Cells(Rows.Count, 1).End(xlUp).Row + 1

For i = 1 To ende_tabelle_fahrten Step 1
If Worksheets("Fahrten").Cells(i, 2).Interior.ColorIndex = 3 Then
Worksheets("Fahrten").Cells(i, 2).Interior.ColorIndex = xlNone
Worksheets("Fahrten").Cells(i, 3).Interior.ColorIndex = xlNone
End If
Next i

flag_tabelle_fahrtkosten_10zeilen_fertig = False

verz_next_page = 1
flag_next_page = False
flag_meisterschaften_ende = False

abrech_next_page = 1

tabelle_fahrt_spalte = 0
tabelle_fahrt_zeile = 0
tabelle_fahrtkosten_spalte = 0
tabelle_fahrtkosten_zeile = 0
tabelle_einzelnachweis_spalte = 0
tabelle_einzelnachweis_zeile = 0
tabelle_endverwendungsnachweis_spalte = 0
tabelle_endverwendungsnachweis_zeile = 0

f = 1 ' Zähler für laufende Nummer in Fahrt
fk = 1 ' Zähler für laufende Nummer in Fahrtkosten
n = 1 ' Zähler für laufende Nummer in Einzel_Nachweis

fk_zeileneintrag = 1
en_zeileneintrag = 1
zeile_fahrten_aktivitaet = 10
blattnr = 1
en_blattnr = 1
zeile_fahrten_start = 10
lfdnr = 1
zeile_meisterschaften_aktivitaet = 5
zeile_fahrtkosten_aktivitaet = 19
flag = True
flag_neues_blatt = False

' Inhalt in den Tabellen leeren für neue Daten
...

Counter = 0
Länge = 0
end_counter = ende_tabelle_meisterschaften - 5

' Daten von "Meisterschaften" in Tabelle "Fahrten" übertragen
For zeile_meisterschaften_aktivitaet = 5 To ende_tabelle_meisterschaften - 1 Step 1

Counter = Counter + 1

' Prozentsatz aktualisieren
PctDone = Counter / (end_counter)
Schritt = PB1.Label1.Width / end_counter

' Text mit Prozentsatz aktualisieren
PB1.Label3.Caption = Format(PctDone, "0%")

' Balkenbreite aktualisieren
Länge = Länge + Schritt
PB1.Label2.Width = Länge

If zeile_meisterschaften_aktivitaet = ende_tabelle_meisterschaften - 1 Then flag_meisterschaften_ende = True

For zeile_fahrten_aktivitaet = zeile_fahrten_start To zeile_fahrten_start + 15 Step 1
' Für jede Zeile in Tabelle Meisterschaften
...

' Eintrag in Tabelle "Fahrten"
...
Weiter1:
Next zeile_fahrten_aktivitaet

zeile_fahrten_start = zeile_fahrten_start + 31
flag = True

' Daten in Tabelle Fahrtkosten eintragen
...

If Worksheets("Fahrten").Cells(zeile_fahrten_aktivitaet, 4).Value = "0" Then
Worksheets("Fahrtkosten").Cells(zeile_fahrtkosten_aktivitaet, 7).Value = Worksheets("Fahrten").Cells(zeile_fahrten_aktivitaet, 5).Value
Else
Worksheets("Fahrtkosten").Cells(zeile_fahrtkosten_aktivitaet, 7).Value = Worksheets("Fahrten").Cells(zeile_fahrten_aktivitaet, 4).Value
End If

Worksheets("Fahrtkosten").Cells(zeile_fahrtkosten_aktivitaet, 8).Value = Worksheets("Fahrten").Cells(zeile_fahrten_aktivitaet, 7).Value

Worksheets("Einzel_Nachweis").Cells(35, 8).Value = Worksheets("Fahrtkosten").Cells(zeile_fahrtkosten_aktivitaet, 7).Value

datumzeile = datumzeile + 31
zeile_fahrtkosten_aktivitaet = zeile_fahrtkosten_aktivitaet + 1

If zeile_fahrtkosten_aktivitaet = 29 Or flag_meisterschaften_ende = True Then
For i = 19 To 28 Step 1
If Worksheets("Fahrtkosten").Cells(i, 1).Value = "" Then
' nichts zu tun
Else
Worksheets("Fahrtkosten").Cells(i, 9).FormulaR1C1 = "=RC[-1]*0.6"
End If
Next i

' Tabelle Fahrtkosten nach Tabelle Fahrtkosten_gesamt übertragen
Worksheets("Fahrtkosten").Range("A1:L30").Copy Worksheets("Fahrtkosten_gesamt").Cells(fk_zeileneintrag, 1)

' Inhalt in Tabelle "Fahrtkosten" leeren für neue Daten
...

zeile_fahrtkosten_aktivitaet = 19
flag_neues_blatt = True

...

blattnr = blattnr + 1
fk_zeileneintrag = fk_zeileneintrag + 30

End If

' Daten in Tabelle "Einzel_Nachweis" eintragen
Worksheets("Einzel_Nachweis").Cells(11, 9).Value = Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 1).Value
Worksheets("Einzel_Nachweis").Cells(12, 1).Value = Worksheets("Basisdaten").Cells(7, 2).Value
Worksheets("Einzel_Nachweis").Cells(12, 3).Value = Worksheets("Basisdaten").Cells(7, 4).Value

Worksheets("Einzel_Nachweis").Cells(17, 4).Value = Worksheets("Basisdaten").Cells(3, 2).Value

Worksheets("Einzel_Nachweis").Cells(18, 4).Value = Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 4).Value
Worksheets("Einzel_Nachweis").Cells(19, 4).Value = Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 2).Value
Worksheets("Einzel_Nachweis").Cells(20, 4).Value = Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 6).Value

If Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 8).Value = "" Then
tagesdatum = Day(Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 10).Value)
monatsdatum = Month(Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 10).Value)
jahresdatum = Year(Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 10).Value)
fixdatum = CStr(tagesdatum & "." & monatsdatum & "." & jahresdatum)
Worksheets("Einzel_Nachweis").Cells(22, 4).Value = fixdatum
Else
tagesdatum_von = Day(Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 8).Value)
monatsdatum_von = Month(Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 8).Value)
jahresdatum = Year(Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 8).Value)
tagesdatum_bis = Day(Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 10).Value)
monatsdatum_bis = Month(Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 10).Value)
If monatsdatum_von = monatsdatum_bis Then
fixdatum = CStr(tagesdatum_von & ".-" & tagesdatum_bis & "." & monatsdatum_bis & "." & jahresdatum)
Else
fixdatum = CStr(tagesdatum_von & "." & monatsdatum_von & "-" & tagesdatum_bis & "." & monatsdatum_bis & "." & jahresdatum)
End If
Worksheets("Einzel_Nachweis").Cells(22, 4).Value = fixdatum
End If

Worksheets("Einzel_Nachweis").Cells(25, 8).Value = Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 11).Value

For i = 3 To ende_tabelle_db - 1 Step 1
en_flag = True
If Worksheets("DB").Cells(i, 1).Value = Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 6).Value Then
If Worksheets("DB").Cells(i, 2).Value = "" Then
MsgBox ("Die Kilometerzahl für " & Worksheets("DB").Cells(i, 1).Value & " fehlt!")
Worksheets("DB").Select
GoTo Ende
Else
Worksheets("Einzel_Nachweis").Cells(29, 8).Value = Worksheets("DB").Cells(i, 2).Value
en_flag = False
GoTo Weiter3
End If
End If
Next i
Weiter3:
Worksheets("Einzel_Nachweis").Cells(30, 8).Value = CStr(CInt(Worksheets("Einzel_Nachweis").Cells(29, 8).Value) * 2)
Worksheets("Einzel_Nachweis").Cells(35, 6).Value = Worksheets("Meisterschaften").Cells(zeile_meisterschaften_aktivitaet, 11).Value

Worksheets("Einzel_Nachweis").Cells(41, 1).Value = Worksheets("Basisdaten").Cells(13, 2).Value
Worksheets("Einzel_Nachweis").Cells(41, 3).Value = Worksheets("Basisdaten").Cells(15, 2).Value

' Tabelle Einzel_Nachweis nach Tabelle Einzel_Nachweis_gesamt übertragen
Worksheets("Einzel_Nachweis").Range("A1:I50").Copy Worksheets("Einzel_Nachweis_gesamt").Cells(en_zeileneintrag, 1)

' Inhalt in Tabelle "Einzel_Nachweis" leeren für neue Daten
Worksheets("Einzel_Nachweis").Cells(11, 9).Value = ""
Worksheets("Einzel_Nachweis").Cells(12, 1).Value = ""
Worksheets("Einzel_Nachweis").Cells(12, 3).Value = ""
Worksheets("Einzel_Nachweis").Cells(17, 4).Value = ""
Worksheets("Einzel_Nachweis").Cells(18, 4).Value = ""
Worksheets("Einzel_Nachweis").Cells(19, 4).Value = ""
Worksheets("Einzel_Nachweis").Cells(20, 4).Value = ""
Worksheets("Einzel_Nachweis").Cells(22, 4).Value = ""
Worksheets("Einzel_Nachweis").Cells(25, 8).Value = ""
Worksheets("Einzel_Nachweis").Cells(29, 8).Value = ""
Worksheets("Einzel_Nachweis").Cells(30, 8).Value = ""
Worksheets("Einzel_Nachweis").Cells(35, 6).Value = ""
Worksheets("Einzel_Nachweis").Cells(35, 8).Value = ""
Worksheets("Einzel_Nachweis").Cells(41, 1).Value = ""
Worksheets("Einzel_Nachweis").Cells(41, 3).Value = ""

en_zeileneintrag = en_zeileneintrag + 50

' DoEvents aktualistiert den UserForm
DoEvents
Next zeile_meisterschaften_aktivitaet

ende_tabelle_fahrten = Worksheets("Fahrten").Cells(Rows.Count, 1).End(xlUp).Row + 1
rangebereich = "A1:G" & CStr(ende_tabelle_fahrten)
Worksheets("Fahrten").Range(rangebereich).Copy Worksheets("Fahrten_save").Cells(1, 1)

If abschluss_flag = True Then
' Daten in Tabelle "End_Verwendungsnachweis" eintragen
...

Weiter5:
' Daten in End_Verwendungsnachweis eintragen
...

Worksheets("End_Verwendungsnachweis").Select

Else
Worksheets("Fahrtkosten_gesamt").Select
End If
Ende:

' Tabelle "Fahrten" nach "Fahrten_save" sichern
ende_tabelle_fahrten = Worksheets("Fahrten").Cells(Rows.Count, 1).End(xlUp).Row + 1
rangebereich = "A1:H" & CStr(ende_tabelle_fahrten)
Worksheets("Fahrten").Range(rangebereich).Copy Worksheets("Fahrten_save").Cells(1, 1)

Application.Wait (Now + TimeValue("0:00:2"))
Unload PB1

' Buttons "Alle Freifahrten mit 'ja' füllen" und "Alle Freifahrten mit 'nein' füllen" wieder aktivieren
Worksheets("Fahrten").Fill_Ja_all.Enabled = True
Worksheets("Fahrten").Fill_Nein_all.Enabled = True

If Application.EnableEvents = True Then
Application.EnableEvents = False
End If

ret = CloseWkbks()

Worksheets("Fahrten").Protect Password:="GBF#1", Contents:=True
Worksheets("DB").Protect Password:="GBF#1", Contents:=True
Worksheets("Meisterschaften").Protect Password:="GBF#1", Contents:=True
Worksheets("Fahrtkosten_gesamt").Protect Password:="GBF#1", Contents:=True
Worksheets("Einzel_Nachweis_gesamt").Protect Password:="GBF#1", Contents:=True
Worksheets("End_Verwendungsnachweis").Protect Password:="GBF#1", Contents:=True

End Sub

Private Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function

Public Function CloseWkbks() As Boolean

Dim WkbkName As Object
On Error GoTo Close_Error
Application.ScreenUpdating = False

For Each WkbkName In Application.Workbooks()
If (WkbkName.Name = "Übungsleiter.xlsm") Then
WkbkName.Close SaveChanges:=False
Else
If (WkbkName.Name = "Überblick_Meisterschaften.xlsm") Then
WkbkName.Close SaveChanges:=False
End If
End If
CloseAllWkbks = True
Next WkbkName

Exit Function

Close_Error:
MsgBox Str(Err) & " " & Error()
Resume Next

CloseAllWkbks = False
End Function