AW: @ fcs - Hilfe!
01.05.2007 18:52:02
fcs
Hallo Dirk,
zu Frage 1:
Ich habe den Code zum Kopieren etwas optimiert. Braucht auf meinem etwas betagten Rechner jetzt ca. 4 bis 5 Sekunden. Wesentlich ist, das das automatische Berechnen während der Ausführung deaktiviert ist. Leider funktionierte das Kopieren der Formate vom Blatt Plan nach Meldung nicht für den ganzen Zellbereich - wahrscheinlich wegen der verschiedensten Prozeduren, die jeweils ablaufen. So werden jetzt ähnlich wie beim Datum ich in einer Schleife die Formate Zelle für Zelle übertragen.
zu Frage 2:
ich hab die notwendigen Änderungen in drei Zeilen unten im Code der Prozedur Worksheets_Change(...) im Blatt "Plan" gekennzeichnet.
Gruß
Franz
Sub PlanZuMeldung()
'kopiert die Plan-Daten zur Meldung
Dim Datum As Date, Zelle As Range
Dim wksMeldung As Worksheet, wksPlan As Worksheet
Dim strBereich$ 'Ausfüllbereich in den Blättern Plan und Meldung
Set wksMeldung = Worksheets("Meldung")
Set wksPlan = Worksheets("Plan")
strBereich$ = "C6:T36" ' Hier Spalte Anpassen wenn weitere Runden dazukommen.
wksMeldung.Select
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With wksMeldung
.Unprotect
.Range("b1").Value = wksPlan.Range("b1").Value 'Monat
.Range("b2").Value = wksPlan.Range("b2").Value 'Jahr
'Datum in Spalte A und B
For Each Zelle In wksPlan.Range("B6:B36")
With .Range(Zelle.Address)
If Zelle.Value = 0 Then
.ClearContents
.Offset(0, -1).ClearContents
Else
Datum = Zelle.Value
.Value = Datum
.Offset(0, -1).Value = Datum
End If
End With
Next
'Daten und Formate in Spalten C bis T übertragen
'Daten übertragen
.Range(strBereich$).Value = wksPlan.Range(strBereich$).Value
'Formate übertragen (Füllfarbe, Fett-, Kursivschrift)
For Each Zelle In wksPlan.Range(strBereich$)
With .Range(Zelle.Address)
.Interior.ColorIndex = Zelle.Interior.ColorIndex
With .Font
.Bold = Zelle.Font.Bold
.Italic = Zelle.Font.Italic
End With
End With
Next
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
Range("C6").Select
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
' Prozedur im Blatt "Plan":
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set Bereich = Range(Cells(6, 3), Cells(36, 3 + Runden * Spalten - 1))
'Prüfung der Eingabe im Eingabebereich der Runden
If Not Intersect(Target, Bereich) Is Nothing Then
For Each rng In Target
'Prüfung auf KITA- oder Fahrer-Spalte
If (rng.Column) Mod Spalten = 0 Or (rng.Column - 1) Mod Spalten = 0 Then
Call Machs(rng) 'Doppelte Eingabe prüfen
End If
Application.EnableEvents = False 'Verhindert die wiederholte Ausführung der Change- _
Prozedur
If Cells(Target.Row, 2) = 0 Then Target.ClearContents 'Kein Datum (Monate mit