Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
240to244
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
240to244
240to244
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Code übertragen schlägt fehl

Code übertragen schlägt fehl
04.04.2003 10:50:36
Andreas
Ich habe Code in einem Tabellenmodul und möchte diesen ersetzen aus einer anderen Arbeitsmappe heraus. Dazu lösche ich vorher den alten Code (klappt) und füge den neuen Code ein. Der neue Code hat ca. 700 Zeilen. Ich verwende die Methoden IsertLines oder AddFromString. Bei ersterer Methode werden die ersten Zeilen übertragen, dann ...Excel verlässt mich; bei der zweiten Methode keinen Erfolg.
Was mache ich bloß falsch, kann mir jemand helfen?


14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Code übertragen schlägt fehl
04.04.2003 11:07:20
Nike

Hi,
poste mal den Code...

bye

Nike

Re: Code übertragen schlägt fehl
04.04.2003 11:17:39
Andreas

Option Explicit

Public Clear_ÜS As Boolean, Kommentar As Boolean, Bewegung As Boolean, Berechnung As Boolean
Public ÜS_HochWert As String
Public letzteZelle As Range
Public Zelladresse As Variant
Dim InternBewegung As Boolean, Primaer As Boolean, NewMonth As Boolean
Dim Antwort As String
Dim l As Long
Dim PlusZelle As Range
Dim Anzahl As Integer
Dim letzterWert(0) As Variant

Public Sub CoBu_NeuerMonat_Click()
Dim Antwort As String, Abrechnen As String
Dim Stelle As Range
Dim V As Integer

For Each Stelle In Range("A11:A41")
If Stelle.Interior.ColorIndex = 3 Then
Stelle.Activate
Antwort = MsgBox("Am " & Cells(Stelle.Row, 2).Value & " sind nicht acht Stunden gearbeitet worden!" & Chr(13) & Chr(13) & "Ist das korrekt?", vbQuestion + vbYesNo, "NEUER MONAT ...")
If Antwort = vbYes Then
Stelle.Interior.ColorIndex = xlNone
Else: Exit Sub
End If
End If
Next Stelle
Antwort = Left(Application.ActivePrinter, Len(Application.ActivePrinter) - 1)
Antwort = MsgBox("Ist der Drucker " & Antwort & " angeschlossen und eingeschaltet?", vbYesNo + vbQuestion, "NEUER MONAT ...")
Cells(ActiveCell.Row, ActiveCell.Column).Activate
If Antwort = vbNo Then Exit Sub
Application.ScreenUpdating = False
Set Stelle = Range("C11:D41").Find("+", LookIn:=xlValues, lookat:=xlPart) 'BIOTRONIK
If Not Stelle Is Nothing Then V = 2
Set Stelle = Range("E11:O41").Find("+", LookIn:=xlValues, lookat:=xlPart) 'andere Aufträge
If Not Stelle Is Nothing Then V = V + 3

Select Case V
Case 0
Abrechnen = MsgBox("Die Stundenabrechnung mit Kommentarliste für " & Range("K3").Text & Format(Range("K3"), " 'yy") & " wird jetzt ausgedruckt und der neue Monat vorbereitet.", vbInformation + vbOKCancel, "NEUER MONAT ...")
If Abrechnen = vbOK Then
ActiveWorkbook.ÜberstundenLöschen = 2
nachAusdruck
End If
Case 2
Do
Abrechnen = InputBox("Die Stundenabrechnung mit Kommentarliste für " & Range("K3").Text & Format(Range("K3"), " 'yy") & " wird jetzt ausgedruckt und der neue Monat vorbereitet." & Chr(13) & Chr(13) & "Wie soll die Abrechnung erfolgen?" & Chr(13) & Chr(13) & Chr(13) & "1 - Überstunden 'BIOTRONIK' abrechnen" & Chr(13) & Chr(13) & "2 - keine Überstunden abrechnen" & Chr(13) & Chr(13) & Chr(13), "NEUER MONAT ...")
Loop Until Abrechnen = "" Or Abrechnen = "1" Or Abrechnen = "2"
Select Case Abrechnen
Case ""
GoTo ExitMonat
Case "1"
ActiveWorkbook.ÜberstundenLöschen = 2
Case "2"
ActiveWorkbook.ÜberstundenLöschen = 4
ClearÜS
End Select
nachAusdruck
Case 3
Do
Abrechnen = InputBox("Die Stundenabrechnung mit Kommentarliste für " & Range("K3").Text & Format(Range("K3"), " 'yy") & " wird jetzt ausgedruckt und der neue Monat vorbereitet." & Chr(13) & Chr(13) & "Wie soll die Abrechnung erfolgen?" & Chr(13) & Chr(13) & Chr(13) & "1 - Überstunden 'andere Aufträge' abrechnen" & Chr(13) & Chr(13) & "2 - keine Überstunden abrechnen" & Chr(13) & Chr(13) & Chr(13), "NEUER MONAT ...")
Loop Until Abrechnen = "" Or Abrechnen = "1" Or Abrechnen = "2"
Select Case Abrechnen
Case ""
GoTo ExitMonat
Case "1"
ActiveWorkbook.ÜberstundenLöschen = 3
Case "2"
ActiveWorkbook.ÜberstundenLöschen = 4
ClearÜS
End Select
nachAusdruck
Case 5
Do
Abrechnen = InputBox("Die Stundenabrechnung mit Kommentarliste für " & Range("K3").Text & Format(Range("K3"), " 'yy") & " wird jetzt ausgedruckt und der neue Monat vorbereitet." & Chr(13) & Chr(13) & "Wie soll die Abrechnung erfolgen?" & Chr(13) & Chr(13) & Chr(13) & "1 - alle Überstunden abrechnen" & Chr(13) & Chr(13) & "2 - nur Überstunden 'BIOTRONIK' abrechnen" & Chr(13) & Chr(13) & "3 - nur Überstunden 'andere Aufträge' abrechnen" & Chr(13) & Chr(13) & "4 - keine Überstunden abrechnen" & Chr(13) & Chr(13) & Chr(13), "NEUER MONAT ...")
Loop Until Abrechnen = "" Or Abrechnen = "1" Or Abrechnen = "2" Or Abrechnen = "3" Or Abrechnen = "4"
Select Case Abrechnen
Case ""
GoTo ExitMonat
Case "1"
ActiveWorkbook.ÜberstundenLöschen = 1
Case "2"
ActiveWorkbook.ÜberstundenLöschen = 2
Case "3"
ActiveWorkbook.ÜberstundenLöschen = 3
Case "4"
ActiveWorkbook.ÜberstundenLöschen = 4
ClearÜS
End Select
nachAusdruck
End Select
ExitMonat:
Clear_ÜS = False
Range("C11").Activate
Application.ScreenUpdating = True

End Sub

Private Sub Worksheet_Activate()
Set letzteZelle = ActiveCell
letzterWert(0) = ActiveCell.Value
letzteZelle.Activate
Berechnung = False
ThisWorkbook.ÜberstundenLöschen = 0
Kommentar = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim KSpalte As Integer, StellePlus As Integer, Urlaubszeile As Integer, KZeile As Integer, x As Integer
Dim Urlaubszelle As Range, UKommentar As Range
Dim Wort As String, Kommentartext As String
Dim KStelle As Range, Zelle As Range

Kommentar = False
If Clear_ÜS = True Or NewMonth = True Then Exit Sub
If letzteZelle.Column <> 8 Then
If Bewegung = True Then
Bewegung = False
ÜS_Eintrag
Kommentar = True
End If
If ActiveSheet.Name = "Stundenabrechnung" And (letzteZelle <> ActiveCell Or ActiveCell = "") Then
StellePlus = 0
StellePlus = InStr(1, letzterWert(0), "+")
If StellePlus <> 0 Then
Clear_ÜS = True
Application.ScreenUpdating = False
KZeile = letzteZelle.Row - 1
On Error Resume Next
letzteZelle.Comment.Delete
On Error GoTo 0
If letzteZelle.Column > 4 Then KSpalte = 9 Else KSpalte = 4
With Worksheets("Überstunden")
.Activate
Set KStelle = .Range(.Cells(KZeile, KSpalte), .Cells(KZeile, KSpalte + 2)).Find(CDbl(Right(letzterWert(0), Len(letzterWert(0)) - StellePlus)))
.Primaer = True
.Range(KStelle.Address).ClearContents
.Berechnen
End With
Worksheets("Stundenabrechnung").Activate
letzteZelle.Activate
Application.ScreenUpdating = True
Berechnen
Clear_ÜS = False
Exit Sub
End If
On Error Resume Next
Kommentartext = letzteZelle.Comment.Text
If Err.Number = 0 Then
If Left(Kommentartext, 4) = "Rest" Then
letzteZelle.Comment.Delete
With Worksheets("Urlaubstage")
For Each Urlaubszelle In .Range("A:A")
If Urlaubszelle = "" Then
Exit For
ElseIf Urlaubszelle = Format(Cells(ActiveCell.Row, 2), "dd.mm.yy") Then
If .Cells(Urlaubszelle.Row + 1, 1) = "" Then
Urlaubszelle.EntireRow.ClearContents
Else
Urlaubszelle.Delete Shift:=xlUp
Urlaubszeile = .Range("B:B").Find("").Row
.Cells(Urlaubszeile - 1, 1).EntireRow.ClearContents
End If
For Each UKommentar In Range(Cells(11, 3), Cells(41, 3))
Wort = Left(UKommentar.Comment.Text, 4)
If Wort = "Rest" Then
Wort = ""
Urlaubszeile = .Range("A:A").Find(Format(Cells(UKommentar.Row, 2), "dd.mm.yy")).Row
UKommentar.Comment.Text .Cells(Urlaubszeile, 2) & " " & .Cells(Urlaubszeile, 3) & ": " & .Cells(Urlaubszeile, 4) & " " & .Cells(Urlaubszeile, 5)
End If
Next UKommentar
Exit For
End If
Next Urlaubszelle
End With
Bereich_UnMerge
Exit Sub
ElseIf Left(Kommentartext, 4) = "acht" Then
Worksheets("Überstunden").Range("N9") = Worksheets("Überstunden").Range("N9").Value + 8
Worksheets("Überstunden").Berechnen
letzteZelle.ClearComments
Bereich_UnMerge
Exit Sub
Else 'Wert wurde mit ENTF gelöscht:
If letzteZelle.Address = ActiveCell.Address And ActiveCell.Text = "" Then
ActiveCell.Comment.Delete
Select Case letzterWert(0)
Case "frei", "Urlaub", "Feiertag", "krank"
letzteZelle.ClearComments
Bereich_UnMerge
Exit Sub
End Select
End If
End If
Else
Select Case letzterWert(0)
Case "frei", "Urlaub", "Feiertag", "krank"
Bereich_UnMerge
Exit Sub
Case "Sa", "So"
Clear_ÜS = True
Cells(letzteZelle.Row, 3) = letzterWert(0)
Clear_ÜS = False
End Select
End If
On Error GoTo 0
End If
If letzteZelle.Row > 5 Then
Select Case letzteZelle.Value
Case "So", "Sa"
Case "frei", "Urlaub", "Feiertag", "krank"
Application.DisplayAlerts = False
x = 0
For Each Zelle In Range(Cells(letzteZelle.Row, 3), Cells(letzteZelle.Row, 14))
If Zelle <> "" Then x = x + 1
Next Zelle
Clear_ÜS = True
If x > 1 Then
MsgBox "Für diesen Eintrag muss der Tag leer sein!", vbExclamation + vbOKOnly, "Falscher Eintrag"
letzteZelle.ClearContents
Else
Wort = letzteZelle.Text
Cells(letzteZelle.Row, letzteZelle.Column) = ""
Cells(letzteZelle.Row, 3) = Wort
Range(Cells(letzteZelle.Row, 3), Cells(letzteZelle.Row, 14)).Merge
Set letzteZelle = Cells(letzteZelle.Row, 3)
End If
Clear_ÜS = False
Application.DisplayAlerts = True
Case Else
If letzteZelle.Row = 6 Then Exit Sub
If letzteZelle = "" Then
Clear_ÜS = True
Berechnung = False
Berechnen
Primaer = False
Exit Sub
End If

Clear_ÜS = True
If IsNumeric(Left(letzteZelle.Text, 1)) <> True Then
letzteZelle = ""
MsgBox "Neben positiven Zahlenwerten kommen nur Begriffe wie frei (f), Urlaub (U), Feiertag (Fe) und krank (k) in Frage!", vbOKOnly + vbInformation, "Falscher Eintrag"
'Worksheets("Überstunden").UeSZelle.ClearContents 'deaktiviert am 14.10.02; verursacht einen Fehler, keine erkennbare Notwendigkeit
'Worksheets("Überstunden").Berechnen 'deaktiviert am 14.10.02; keine erkennbare Notwendigkeit
ElseIf Cells(6, letzteZelle.Column) = "" Then
letzteZelle = ""
MsgBox "Kein Projekt vorhanden!", vbOKOnly + vbExclamation, "Falscher Eintrag"
Else
Berechnung = False
Berechnen
End If
Clear_ÜS = False
End Select
End If
End If
If Berechnung = True Then
Berechnung = False
'Berechnen
Application.Calculation = xlCalculationAutomatic
End If
End Sub

Private Sub Worksheet_Deactivate()
If Bewegung = True Then
If Range(Zelladresse) = letzteZelle Then
With Worksheets("Überstunden")
.Primaer = True
.Range(.UeAdresse).ClearContents
.Berechnen
MsgBox "Der Überstundenwert wurde keiner Arbeitszeit zugeordnet - Wert gelöscht!", vbOKOnly + vbInformation, "Überstundenupdate"
End With
End If
End If
ÜS_HochWert = ""
InternBewegung = False
Bewegung = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim Fehler As Boolean, Urlaub_ As Boolean
Dim Text_Kommentar As String, Zeitspanne As String, Kommentar_ As String
Dim RZe As Integer, Zeile As Integer
Dim Urlaubsjahr

Select Case ActiveCell.Row
Case 11 To 41
Range("B11:B41").Interior.ColorIndex = xlNone
Cells(ActiveCell.Row, 2).Interior.ColorIndex = 15
Case 5
Cells(6, ActiveCell.Column).Activate
Case 42
Cells(41, ActiveCell.Column).Activate
End Select

Select Case ActiveCell.Column
Case Is < 3
Cells(ActiveCell.Row, 3).Activate
Case Is > 14
Cells(ActiveCell.Row, 14).Activate
End Select

If Bewegung = True Then
Range(Zelladresse).Activate
Set letzteZelle = Range(Zelladresse)
Exit Sub
End If

If letzteZelle.Column = 8 Then GoTo Sprung

If Kommentar = False Then
If Berechnung = False Then
Select Case letzteZelle
Case "Urlaub"
Urlaub_ = True
GoTo Urlaub
Case "frei", "Feiertag"
Kommentar = True
Cells(ActiveCell.Row, 2).Interior.ColorIndex = xlNone
letzteZelle.Activate
Antwort = InputBox("Kommentar:", Format(Cells(letzteZelle.Row, 2), "d. mmmm"), Text_Kommentar)
Fehler = True
GoTo Urlaubsantwort
End Select
If IsNumeric(Left(letzteZelle.Text, 1)) = True Then
Urlaub:
Kommentar = True
Cells(ActiveCell.Row, 2).Interior.ColorIndex = xlNone
letzteZelle.Activate
On Error Resume Next
Kommentar_ = letzteZelle.Comment.Text
If Err.Number <> 0 Then '(kein Kommentar)
Fehler = True
RZe = letzteZelle.Row
Do
On Error GoTo 0
On Error Resume Next
RZe = RZe - 1
Text_Kommentar = Cells(RZe, letzteZelle.Column).Comment.Text
Loop Until RZe = 10 Or Err.Number = 0
Else '(Kommentar vorhanden)
Text_Kommentar = Kommentar_
End If
On Error GoTo 0
If Urlaub_ = True And Fehler = True Then
If Worksheets("Überstunden").Range("N9").Value >= 8 Then
Antwort = MsgBox("Soll dieser Urlaubstag mit dafür bereits zurückgestellten Überstunden " & "verrechnet werden?", vbQuestion + vbYesNo, "Urlaubstag")
If Antwort = vbYes Then
With Worksheets("Überstunden")
.Range("N9") = .Range("N9").Value - 8
.Range("N41") = ""
.Berechnen
End With
Antwort = "acht bereits dafür zurückgestellte Überstunden als Urlaub verrechnet"
GoTo Urlaubsantwort
End If
End If
With Worksheets("Urlaubstage")
Zeile = .Range("A:A").Find("", lookat:=xlWhole).Row - 1
If Zeile > 2 Then
Anzahl = .Cells(Zeile, 4).Value
If Anzahl = 0 Then '(kein Tag mehr vorhanden)
Antwort = InputBox("Es ist kein weiterer Urlaubstag vom Jahr " & .Cells(Zeile, 3).Value & " vorhanden!" & Chr(13) & Chr(13) & Chr(13) & "1 - Urlaubstag wird als 'frei' eingetragen" & Chr(13) & Chr(13) & "2 - Urlaubstag ist der Erste für das Jahr " & .Cells(Zeile, 3).Value + 1 & Chr(13) & Chr(13), "Urlaubstage " & .Cells(Zeile, 3).Value)
Select Case Antwort
Case "1"
ActiveCell = "frei"
Antwort = InputBox("Kommentar:", Format(Cells(letzteZelle.Row, 2), "d. mmmm"), Text_Kommentar)
GoTo Urlaubsantwort
Case "2"
.Cells(Zeile + 1, 1) = Format(Cells(letzteZelle.Row, 2), "dd.mm.yy")
.Cells(Zeile + 1, 2) = "Rest"
.Cells(Zeile + 1, 3) = .Cells(Zeile, 3).Value + 1
.Cells(Zeile + 1, 4) = 23
.Cells(Zeile + 1, 5) = "Tage"
Antwort = "Rest " & .Cells(Zeile, 3).Value + 1 & ": 23 Tage"
GoTo Urlaubsantwort
Case Else
ActiveCell = ""
GoTo Ende
End Select
Else: Anzahl = Anzahl - 1
If Anzahl = 1 Then
Zeitspanne = " Tag"
Else: Zeitspanne = " Tage"
End If
Text_Kommentar = .Cells(Zeile, 2) & " " & .Cells(Zeile, 3) & ": " & Anzahl & Zeitspanne
End If
Urlaubsjahr = .Cells(Zeile, 3).Value
Else
Text_Kommentar = "Rest " & Format(Range("K3"), "YYYY") & ": 23 Tage"
Anzahl = 23
Zeitspanne = "Tage"
Urlaubsjahr = Format(Range("K3"), "YYYY")
End If
Antwort = MsgBox(Text_Kommentar, vbInformation + vbOKCancel, "Urlaub - " & Format(Cells(letzteZelle.Row, 2), "d. mmmm") & " - Kommentar")
If Antwort = vbCancel Then
Clear_ÜS = True
letzteZelle = ""
Bereich_UnMerge
Clear_ÜS = False
GoTo Sprung
Else
Antwort = Text_Kommentar
.Cells(Zeile + 1, 1) = Format(Cells(letzteZelle.Row, 2), "dd.mm.yy")
.Cells(Zeile + 1, 2) = "Rest"
.Cells(Zeile + 1, 3) = Urlaubsjahr
.Cells(Zeile + 1, 4) = Anzahl
.Cells(Zeile + 1, 5) = Trim(Zeitspanne)
End If
End With
Else
If IsNumeric(Left(letzteZelle.Text, 1)) = True Then
If Bewegung = True Then
InternBewegung = True
Bewegung = False
End If
Antwort = InputBox("Kommentar über Tätigkeit der " & letzteZelle.Value & " h:", Format(Cells(letzteZelle.Row, 2), "d. mmmm"), Text_Kommentar)
Else: GoTo Sprung
End If
End If
Urlaubsantwort:
If Antwort <> "" Then
With letzteZelle
If Fehler = False Then 'Kommentar schon vorhanden
If Antwort <> "" Then
.Comment.Text (Antwort)
Kommentargroesse
Else
.Comment.Delete
GoTo Ende
End If
Else
If Antwort <> "" Then
.AddComment.Text (Antwort)
Kommentargroesse
End If
End If
End With
Ende:
Cells(ActiveCell.Row + 1, ActiveCell.Column).Activate 'um bei Blatt Überstunden neu zu berechnen
End If
End If
End If
End If
Sprung:
Set letzteZelle = ActiveCell
letzterWert(0) = ActiveCell.Value
Kommentar = False
Berechnung = True
End Sub

Public Sub Berechnen()
Dim Hochbetrag As Double, HochbetragBiotronik As Double, HochbetragAndere As Double
Dim BetragBiotronik As Double, BetragAndere As Double
Dim PlusPos As Integer, n As Integer
Dim Spaltenbetrag As Variant
Dim Zelle As Range

Application.Calculation = xlCalculationManual
Pieps
For n = 3 To 14
If n <> 8 Then
Spaltenbetrag = 0
Hochbetrag = 0
If Cells(6, n) <> "" Then
For Each Zelle In Range(Cells(11, n), Cells(41, n))
If IsNumeric(Left(Zelle.Text, 1)) = True Then
If InStr(Zelle.Text, "+") <> 0 Then
PlusPos = InStr(Zelle.Text, "+")
Spaltenbetrag = Spaltenbetrag + CDbl(Left(Zelle.Text, PlusPos - 1))
Hochbetrag = Hochbetrag + CDbl(Mid(Zelle.Text, PlusPos + 1, Len(Zelle.Text)))
Else: Spaltenbetrag = Spaltenbetrag + Zelle.Value
End If
End If
Next Zelle
End If

If Spaltenbetrag <> 0 And Hochbetrag <> 0 Then
If Cells(42, n) <> Spaltenbetrag & " +" & Hochbetrag Then
Cells(42, n) = Spaltenbetrag & " +" & Hochbetrag
Cells(42, n).Characters(Len(Str(Spaltenbetrag)) + 1).Font.Superscript = True
End If
ElseIf Spaltenbetrag <> 0 And Hochbetrag = 0 Then
If Cells(42, n) <> Spaltenbetrag Then
Cells(42, n) = Spaltenbetrag
End If
ElseIf Spaltenbetrag = 0 And Hochbetrag <> 0 Then
If Cells(42, n) <> "0 +" & Hochbetrag Then
Cells(42, n) = "0 +" & Hochbetrag
Cells(42, n).Characters(Len(Str(Spaltenbetrag)) + 1).Font.Superscript = True
End If
Else: If Cells(42, n) <> "" Then Cells(42, n).ClearContents
End If

Select Case n
Case 3 To 4
BetragBiotronik = BetragBiotronik + Spaltenbetrag
HochbetragBiotronik = HochbetragBiotronik + Hochbetrag
Case 5 To 14
BetragAndere = BetragAndere + Spaltenbetrag
HochbetragAndere = HochbetragAndere + Hochbetrag
End Select
End If
Next
If BetragAndere + BetragBiotronik <> 0 Or HochbetragBiotronik + HochbetragAndere <> 0 Then
If HochbetragBiotronik + HochbetragAndere <> 0 Then
Cells(43, 3) = BetragAndere + BetragBiotronik & " +" & HochbetragBiotronik + HochbetragAndere
Cells(43, 3).Characters(Len(Str(BetragAndere + BetragBiotronik)) + 1).Font.Superscript = True
Else
Cells(43, 3) = BetragAndere + BetragBiotronik
End If
Else: Cells(43, 3) = ""
End If
If BetragBiotronik <> 0 Or HochbetragBiotronik <> 0 Then
If HochbetragBiotronik <> 0 Then
Cells(43, 6) = BetragBiotronik & " +" & HochbetragBiotronik
Cells(43, 6).Characters(Len(Str(BetragBiotronik)) + 1).Font.Superscript = True
Else
Cells(43, 6) = BetragBiotronik
End If
Else: Cells(43, 6) = ""
End If
Clear_ÜS = False
If Worksheets("Überstunden").UeSAbrechnung = False And NewMonth = False Then AchtStundenTest

End Sub

Public Sub ÜS_Eintrag()
Dim Länge As Integer

Clear_ÜS = True
Länge = Len(letzteZelle.Text)
letzteZelle = letzteZelle & " +" & ÜS_HochWert
letzteZelle.Characters(Länge + 1).Font.Superscript = True
Clear_ÜS = False
End Sub

Public Sub Kommentargroesse()
With ActiveCell
.Comment.Visible = True
.Comment.Shape.Select
Selection.AutoSize = True
.Comment.Visible = False
End With
End Sub

Public Sub nachAusdruck()
Dim Zelle As Range

NewMonth = True
Worksheets("Überstunden").Activate 'um auf den Wert von ÜberstundenLöschen reagieren zu können
Worksheets("Stundenabrechnung").Activate
ActiveSheet.PrintOut From:=1, to:=1
Worksheets("Kommentare").Activate
Worksheets("Kommentare").PrintOut From:=1, to:=1
Worksheets("Stundenabrechnung").Activate
Range("K3") = DateAdd("m", 1, Range("K3"))
Range("C11:O42").ClearContents
Range("C11:O41").ClearComments
Cells(43, 3).ClearContents
Cells(43, 6).ClearContents

With Range("C11:N41")
.UnMerge
.Borders(xlInsideVertical).ColorIndex = xlAutomatic
End With
SpaltenLayoutEinstellen 11, 41
For Each Zelle In Range("C11:C41")
Range("C" & Zelle.Row & ":N" & Zelle.Row).Interior.ColorIndex = xlNone
Select Case WeekDay(Cells(Zelle.Row, 2))
Case 7
Zelle = "Sa"
Range("C" & Zelle.Row & ":N" & Zelle.Row).Interior.ColorIndex = 15
Case 1
Zelle = "So"
Range("C" & Zelle.Row & ":N" & Zelle.Row).Interior.ColorIndex = 15
End Select
Next Zelle
NewMonth = False
End Sub

Public Sub ClearÜS()
Clear_ÜS = True
With Range("C11:O43")
Set PlusZelle = .Find("+")
If Not PlusZelle Is Nothing Then
Do
PlusZelle = Left(PlusZelle, InStr(1, PlusZelle.Text, "+") - 2)
If PlusZelle.Text = "0" Then PlusZelle = ""
Set PlusZelle = .FindNext(PlusZelle)
Loop Until PlusZelle Is Nothing
End If
End With
End Sub

Public Sub Pieps()
Dim n As Integer

For n = 1 To 50000
Select Case n
Case 1, 50000
Beep
End Select
Next n
End Sub

Public Sub AchtStundenTest()
Dim AnzStu As Double
Dim n As Integer, m As Integer, y As Integer

For n = 11 To 41
AnzStu = 0
For m = 3 To 14
If m <> 8 Then
y = 0
Select Case Cells(n, m)
Case ""
Case "frei", "Feiertag", "Urlaub", "Sa", "So", "krank"
Exit For
Case Else
y = InStr(1, Cells(n, m).Text, "+")
If y <> 0 Then
AnzStu = AnzStu + CDbl(Left(Cells(n, m).Text, y - 1))
Else: AnzStu = AnzStu + CDbl(Cells(n, m).Text)
End If
End Select
End If
Next
Select Case AnzStu
Case 0, 8
Cells(n, 1).Interior.ColorIndex = xlNone
Case Else
Cells(n, 1).Interior.ColorIndex = 3
End Select
Next
End Sub

Public Sub Bereich_UnMerge()
Range(Cells(letzteZelle.Row, 3), Cells(letzteZelle.Row, 14)).UnMerge
SpaltenLayoutEinstellen letzteZelle.Row, letzteZelle.Row
Worksheets("Urlaubstage").Activate
Worksheets("Stundenabrechnung").Activate
Cells(letzteZelle.Row + 1, 3).Activate
End Sub

Public Sub SpaltenLayoutEinstellen(Zeile1 As Integer, Zeile2 As Integer)
With Range(Cells(Zeile1, 3), Cells(Zeile2, 4)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Range(Cells(Zeile1, 4), Cells(Zeile2, 5)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Range(Cells(Zeile1, 5), Cells(Zeile2, 7)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Range(Cells(Zeile1, 7), Cells(Zeile2, 8)).Borders(xlInsideVertical)
.LineStyle = xlDash
.Weight = xlThin
End With
With Range(Cells(Zeile1, 8), Cells(Zeile2, 9)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Range(Cells(Zeile1, 9), Cells(Zeile2, 14)).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End Sub

Anzeige
Re: Code übertragen schlägt fehl
04.04.2003 12:04:27
Nike

Hi,
poste mal den Code...

bye

Nike

Re: Code übertragen schlägt fehl
04.04.2003 12:06:10
Nike

Hi,
ich meinte eigentlich nur den Abschnitt,
der dir Probleme bereitet
mit Insert usw. ;-)

Schau mal hier rein:
https://www.herber.de/forum/archiv/56to60/t57372.htm

Bye

Nike

Anzeige
Re: ja, supertoll, jetzt bin ich auch Doppelposter
04.04.2003 12:08:03
Nike

sorry, aber ich hatte wohl ein paar Fenster zuviel auf und
überall auf Absenden gedrückt.
Sorry.

Bye

Nike

Re: Code übertragen schlägt fehl
04.04.2003 12:17:23
Andreas

Option Explicit

Public UpdateProjekt As VBProject
Public UpdateMappe As Workbook
Dim Block As VBComponent
Dim Ze As Long
Dim Antwort As String

Public Sub DoUpdate()
Dim AM As Workbook

Set UpdateMappe = Nothing
For Each AM In Workbooks
If InStr(1, AM.Name, "abrechnung") <> 0 Then
Antwort = MsgBox("Das Update mit Datei " & AM.Name & " durchführen?", vbQuestion + vbYesNoCancel, _
"Update von Monatsabrechnung")
Select Case Antwort
Case vbYes
Set UpdateMappe = AM
Exit For
Case vbCancel
Exit Sub
End Select
End If
Next AM
If UpdateMappe Is Nothing = True Then
MsgBox "Es wurde keine Arbeitsmappe für das Update gefunden.", vbInformation, "Update von Monatsabrechnung"
Exit Sub
End If

If UpdateMappe.VBProject.Protection = vbext_pp_locked Then
MsgBox "Update mit gesperrtem Projekt ist nicht möglich!", vbInformation, "Update von Monatsabrechnung"
Exit Sub
End If

If UpdateMappe.Saved = False Then
Antwort = MsgBox("Änderungen in Datei " & UpdateMappe.Name & " sind nicht gesichert!" & Chr(13) & Chr(13) & _
"Datei wird jetzt in " & UpdateMappe.Path & " gespeichert und das Update durchgeführt.", vbQuestion + vbOKCancel, _
"Update von Monatsabrechnung")
Select Case Antwort
Case vbOK
UpdateMappe.Save
Case vbCancel
Exit Sub
End Select
End If

DeleteCode
UpdateMappe.Save
If CopyCode = True Then
'UpdateMappe.Save
Else
'UpdateMappe.Close False
End If
End Sub

Private Sub DeleteCode()
For Each Block In UpdateMappe.VBProject.VBComponents
Block.CodeModule.DeleteLines 1, Block.CodeModule.CountOfLines
Next Block
End Sub

Private Function CopyCode() As Boolean
CopyCode = True
For Each Block In UpdateMappe.VBProject.VBComponents
On Error Resume Next
' Ze = UpdateProjekt.VBComponents(Block.Name).CodeModule.CountOfLines
' Block.CodeModule.AddFromString UpdateProjekt.VBComponents(Block.Name).CodeModule.Lines(1, Ze)
For Ze = 1 To UpdateProjekt.VBComponents(Block.Name).CodeModule.CountOfLines
DoEvents
Block.CodeModule.InsertLines Ze, UpdateProjekt.VBComponents(Block.Name).CodeModule.Lines(Ze, 1)
Next
If Err.Number <> 0 Then
MsgBox "Fehler " & Err.Number & " beim Update! Der Vorgang wird abgebrochen und die Datei " & _
UpdateMappe.Name & " geschlossen!", vbInformation, "Update von Monatsabrechnung"
CopyCode = False
Exit Function
End If
On Error GoTo 0
Next Block
End Function


Anzeige
Re: Code übertragen schlägt fehl
04.04.2003 12:38:23
Andreas

...habe den zu übertragenden Code einer Variablen zugewiesen und die notwendigen Befehle in With-Blöcke gesetzt - jetzt geht es super - ohne Excel-Abstürze.

Danke für den Link!

Re: Code übertragen schlägt fehl
04.04.2003 13:12:38
Nike

Hi,
wäre gut (für`s Archiv)
wenn du Deine Lösung auch posten könntest,
dann könnte man mal wieder ein Link setzen ;-)

Muß aber nicht, wär halt nur einfach gut...

Bye

Nike

Re: Code übertragen schlägt fehl
04.04.2003 13:48:50
Andreas

Ja, du hast Recht, aber im Prinzip hast du mir durch den schon vorhandenen Link die Lösung nahegebracht. Wenn du jetzt immernoch dieser Ansicht bist, könntest du mir die Vorgehensweise dazu schildern, da ich nicht zu oft bei Herber herumstöbere :-).

Anzeige
Re: Code übertragen schlägt fehl
04.04.2003 14:09:10
Nike

Hi,
ich meinte eigentlich einfach nur den Code
den Du jetzt basierend auf der Lösung entwickelt
hast hier als Beitrag posten.
Der wird dann automatisch Archiviert...

Kleiner Tip mit ...
Tilde begin Tilde
Code
Tilde end Tilde

...kannst du den Code automatisch formatieren lassen
Tilde entspricht dem Zeichen ~

Bye

Nike


Re: Code übertragen schlägt fehl
04.04.2003 15:04:18
Andreas

~ begin ~
Private Function CopyCode() As Boolean
Dim Text as String

CopyCode = True
For Each Block In UpdateMappe.VBProject.VBComponents
On Error Resume Next
With UpdateProjekt.VBComponents(Block.Name).CodeModule
Text = .Lines(1, .CountOfLines)
End With
With Block.CodeModule
.AddFromString Text
End With
If Err.Number <> 0 Then
MsgBox "Fehler " & Err.Number & " beim Update! Der Vorgang wird abgebrochen und die Datei " & _
UpdateMappe.Name & " geschlossen!", vbInformation, "Update von Monatsabrechnung"
CopyCode = False
Exit Function
End If
On Error GoTo 0
Next Block
End Function
~ end ~

Anzeige
Re: kleine Korrektur
04.04.2003 15:38:39
Nike

Hi,
das mit der tilde sollte eigentlich als ein Begiff ohne Leerzeichen geschrieben werden, nur so werden sie erkannt ;-)
~begin~

Nur als Hinweis für die Zukunft ;-)

Bye

nike

Re: kleine Korrektur
04.04.2003 16:06:19
Andreas



300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige