AW: Funktioniert es?
14.12.2015 09:59:40
Ro
Hallo Michael du VBA Gott :D ,
hatte am Wochenende leider viel zu tun und kam nicht zum VBA Code testen...
Code funktioniert im Testumfeld super gut! Du bist einfach ein echter Experte :)
Ich weiß gar nicht wie ich dir dafür Danken kann :o
Allerdings bekomme ich beim Implementieren in den "Komplettcode" immer eine Fehlermeldung in der Zeile Application.Undo....
Ich weiß langsam echt nicht mehr ob ich es jemals schaffen werde den Code ganz zum laufen zu bringen :(
Vllt kannst du mir ja ein letztes Mal helfen!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim einzelZelle As Range
Dim dasDatum As Variant
Dim Aussteigen As Boolean
For Each einzelZelle In Target.Cells
Aussteigen = False
If Target.Column > 7 And Target.Row > 17 Then
If UCase(einzelZelle.Text) = "V" Then
Do
dasDatum = InputBox("Bitte geben Sie das Datum der abgeschlossenen _
Wirksamkeitsprüfung ein." & vbCrLf & "Das Datum muss mit dem Datum im Schulungsprotokoll übereinstimmen.", "Datumsabfrage", Format(Date, "DD.MM.YYYY"))
If dasDatum = "" Then
Aussteigen = MsgBox("Wollen Sie den Eintrag abbrechen? Das V wird _
in diesem Fall gelöscht.", vbYesNo) = vbYes
End If
Loop Until IsDate(dasDatum) Or Aussteigen
If Aussteigen Then
Application.EnableEvents = False
einzelZelle.ClearContents
Application.EnableEvents = True
Else
Tabelle7.Cells(einzelZelle.Row, einzelZelle.Column) = CDate(dasDatum)
MsgBox "Das Datum wurde im Schulungskalender hinterlegt."
End If
Else
Tabelle7.Cells(einzelZelle.Row, einzelZelle.Column).ClearContents
If InStr(1, UCase("ebsbü"), UCase(einzelZelle.Text)) = 0 Then MsgBox "Das _
zugehörige Datum im Schulungskalender wurde gelöscht."
End If
End If
Next einzelZelle
' "mit ohne" doppelte "sb"
Dim Finder As String
Dim Finder1 As String
Dim erste As String
Dim Zelle As Range
Dim Zelle1 As Range
Dim Zelle2 As Range
Dim wksDst As Worksheet
Dim lrow As Long
Dim raus As Boolean
Dim letzter As Variant
Dim Tz As Range ' TargetZellen
Const nichtwenn = ",ü,eb,v,"
If Target.Count > 1 Then MsgBox "mehrere Zellen markiert"
For Each Tz In Target
If Target.Column > 7 And Tz.Row > 17 Then
Finder = Tabelle2.Cells(Tz.Row, 2).Value
Finder1 = Tabelle2.Cells(7, Tz.Column)
Set wksDst = ActiveWorkbook.Sheets(4)
If Trim(LCase(Tz.Value)) = "sb" Then
' Recherche: excel vba worksheet_change letzter wert
letzter = Trim(LCase(Tz.Value))
Application.EnableEvents = False
Application.Undo
' MsgBox "letzer: " & letzter & " tz " & Tz.Value
If Trim(LCase(Tz.Value)) = "sb" Then
Application.EnableEvents = True
Else
Tz.Value = "sb" ' erneut setzen
Application.EnableEvents = True
lrow = wksDst.Cells(Rows.Count, 2).End(xlUp).Row + 1
wksDst.Cells(lrow, 3) = Tabelle2.Cells(Tz.Row, 2)
wksDst.Cells(lrow, 2) = Tabelle2.Cells(7, Tz.Column)
wksDst.Cells(lrow, 4) = Tabelle2.Cells(5, Tz.Column)
End If
Else
If LCase(Tz.Value) = "" Or (LCase(Tz.Value) "" And InStr(nichtwenn, _
"," & LCase(Tz.Value) & ",") = 0) Then
Set Zelle = wksDst.Columns(3).Find(Finder)
If Not Zelle Is Nothing Then
erste = Zelle.Address
raus = False
While Zelle.Offset(0, -1) Finder1 And Not raus
Set Zelle = wksDst.Columns(3).FindNext(Zelle)
If erste = Zelle.Address Then raus = True
Wend
If Not raus Then
Zelle.EntireRow.Delete
MsgBox ("Die Zeile in Tabelle2 wurde gelöscht.")
End If
End If
End If
End If
End If ' Target.Column > 1 And Tz.Row > 2 Then
Next
End Sub
Und das mit dem LCase hat das letzte mal einfach nicht richtig funktioniert, deswegn habe ich gedacht ich schreibe diese Zeile anders.
Hoffentlich hast du noch etwas Geduld mit mir....
Ganz liebe Grüße von der Roxi
