AW: Zellen- Inhalt auf Zahl 0 zurücksetzen
02.09.2008 22:21:42
Lemmi
Hallo Udo,
wie bekomme ich die Funktion in das vorhandenen Marko eingebunden?
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 = 16
'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:O1000 werden in E3 mit Datum protokolliert
If Not Intersect(Target, ws.Range("C6:O1000")) Is Nothing Then
ws.Range("E3") = Now
'Veränderungen im Bereich E6:E1000 werden in derjewaligen Zeile in Spalte C mit Datum _
_protokolliert
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,O6:O1000 werden in derjewaligen Zeile und _
Spalte N mit Datum protokolliert
If Not Intersect(Target, ws.Range("G6:H1000,M6:M1000,O6:O1000")) Is Nothing Then
ws.Range("N" & Target.Row) = Date
End If
'Veränderungen im Bereich H6:H1000 werden in derjewaligen Zeile und Spalte H 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
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