AW: Prozedur scheller machen?
23.09.2008 20:20:00
Lemmi
Hallo Hajo,
schau doch mal! ich glaube das alle Code von euch recht gut wahren! (das kann ich leider nciht so beurteilen da ich nicht so ein Könner bin!
Function myKW(newD As Date) As Integer
Dim myDay As Double
myDay = DateSerial(Year(newD + (8 - Weekday(newD)) Mod 7 - 3), 1, 1)
myKW = (newD - myDay - 3 + (Weekday(myDay) + 1) Mod 7) \ 7 + 1
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet, n As Long
If Target.Count > 1 Then Exit Sub 'nicht bei Markierung mehrerer Zellen
Set ws = ActiveSheet
n = 17
'bestimmte Excel-Aktivitäten abschalten
getMoreSpeed True
If Target.Column = n Then
'wenn die Anzahl der Aktivitäten im Change-Ereignis unübersichtlich werden, _
dann sollte man zusammenhängende Aktionen in Unterprozeduren auslagern und _
die aktive Tabelle sowie Target als Parameter übergeben
x_Felder_Setzen ws, Target, n
getMoreSpeed False
'und Tschüs...
Exit Sub
End If
'If Application.CutCopyMode Then Exit Sub 'nicht beim Kopieren/Ausschneiden
'Veränderungen im Bereich C6:P1000 werden in E3 mit Datum protokolliert
If Not Intersect(Target, ws.Range("C6:P1000")) Is Nothing Then
ws.Range("E3") = Now
'Veränderungen im Bereich E6:E1000 werden in derjewaligen Zeile in Spalte C mit Datum _
_protokolliert; Aufnahme des Arbeitspunktes
If Not Intersect(Target, ws.Range("E6:F1000")) Is Nothing Then
ws.Range("C" & Target.Row) = Date
End If
'Veränderungen im Bereich G6:H1000,M6:M1000,P6:P1000 werden in derjewaligen Zeile und _
Spalte N mit Datum protokolliert
If Not Intersect(Target, ws.Range("G6:H1000,M6:M1000,P6:P1000")) Is Nothing Then
ws.Range("N" & Target.Row) = Date
End If
'Veränderungen im Bereich H6:H1000 werden in derjewaligen Zelle (Spalte N) mit Datum _
protokolliert
If Not Intersect(Target, ws.Range("H7:H1000")) Is Nothing Then
'Target.Value = Target.Value & " " & Now ' mit Datum und Uhrzeit: hh:mm:ss
'oder
'Target.Value = Target.Value & " " & Date ' nur mit Datum
'oder
' mit Datum und KW
Target.Value = Target.Value & ", " & Date & ", KW" & myKW(Date) ' mit Datum und KW; _
Function myKW(newD As Date) As Integer ist hinzu gekommen
End If
End If
getMoreSpeed False
Set ws = Nothing
On Error GoTo ERRHDL
Application.EnableEvents = False
If Target.Count = 1 And Target.Column = 16 Then
Select Case LCase(Target.Value)
Case "erledigt": Target.Offset(0, -3) = 0
Case "offen": Target.Offset(0, -3) = 2
Case "verworfen": Target.Offset(0, -3) = ""
'Case "Status ?": Target.Offset(0, -2) = "xxx"
End Select
End If
ERRHDL:
Application.EnableEvents = True
If Not Intersect(Target, Range("A6:AB500")) Is Nothing Then Call Update_Zellenhoehe
End Sub
Private Sub x_Felder_Setzen(y_ws As Worksheet, y_Target As Range, y_N As Long)
Dim rg1 As Range, rg2 As Range, rg3 As Range, _
s1 As String, _
n1 As Long, _
ok1 As Boolean, ok2 As Boolean
s1 = "x"
If s1 = y_Target.Value Then
'Zelle In Spalte 'A' gleiche Zeile
Set rg1 = y_Target.Offset(0, (-y_N + 1))
If "" = rg1.Value Then
'wenn Zelle in Spalte 'A' leer, dann Makro-Ende
Set rg1 = Nothing
y_Target.Value = ""
Exit Sub
Else
'Prüfen, ob in Spalte 'B' gleiche Zeile der Wert 0 steht, _
(1. Zeile Themenbereich)
ok1 = rg1.Offset(0, 1).Value = 0
End If
If ok1 Then
'wenn in Spallte B der Wert '0' steht (also 1. Zeile Themenbereich)
ok2 = True
'nächste Zelle in Spalte 'A'
Set rg2 = rg1.Offset(1, 0)
Do While ok2
'solange Schleife durchlaufen, wie in der nächsten Zelle in Spalte 'A' _
der gleiche Wert steht wie in der Zelle darüber
If rg2.Value = rg1.Value Then
'nicht jede Zelle in Spalte 'P' einzeln löschen, sondern erst _
alle Zellen erfassen
If rg3 Is Nothing Then
Set rg3 = rg2
Else
Set rg3 = Union(rg3, rg2)
Set rg2 = rg2.Offset(1, 0)
End If
Else
'Schleifenabbruch
ok2 = False
End If
Loop
If Not rg3 Is Nothing Then
'da die Zellen der Spalte 'A' erfaßt wurden, den Wertebereich um _
15 Spalten nach rechts verschieben (Spalte 'P')
rg3.Offset(0, (y_N - 1)).Value = ""
End If
Else
'wenn nicht 1. Zeile im Themenbereich
n1 = rg1.Value
'suchen des 1. Wertes (ist somit 1. Zeile im Themenbereich
'da die Zellen der Spalte 'A' formatiert sind, muß xlFormulas statt xlValues _
angegeben werden
Set rg1 = y_ws.Columns(1).Find(n1, , xlFormulas, xlWhole, xlByColumns, xlNext)
If Not rg1 Is Nothing Then
rg1.Offset(0, (y_N - 1)).Value = ""
End If
End If
End If
Set rg1 = Nothing
Set rg2 = Nothing
Set rg3 = Nothing
End Sub
Gruß
Lemmi