Option Explicit
Private Sub cmbAktZBearbeiten_Click()
Dim BearbZ As String, sPath As String
sPath = "H:\My Documents\TEST_Speicherort\"
BearbZ = InputBox("Bitte Zeichen der zu bearbeitenden Datei eingeben.")
If BearbZ = "" Then
MsgBox "Bitte ein Zeichen eingeben!"
ElseIf Dir(sPath & BearbZ & ".xls") = "" Then
MsgBox "Datei mit diesem Zeichen nicht vorhanden."
Else
Workbooks.Open Filename:=sPath & BearbZ & ".xls"
End If
End Sub
Private Sub cmbAktZNeu_Click()
Dim Zeichen
Dim byWert As Byte
Dim rng As Range
byWert = MsgBox("Bei der Angabe eines neuen Zeichens werden alle Eintragungen gelöscht!" & vbCrLf & _
"Soll ein neues Zeichen erfasst werden?", vbYesNo + vbCritical)
If byWert = vbYes Then
Zeichen = InputBox("Bitte das Zeichen eingeben.")
Sheets("Status").Activate
Range("E1:H1") = Zeichen
Call Kopieren
xLöschen Sheets(1).Range("D5:H9,D11:H19,D22:H29")
xLöschen Sheets(2).Range("D4:H10,D12:H17")
xLöschen Sheets(3).Range("D4:H8,D11:H15")
Else
Exit Sub
End If
End Sub
Private Function xLöschen(rng As Range)
Dim R&, C&, V
For Each V In rng
If Not IsError(V) Then
If LCase(V) = "x" Then
V.Value = ""
End If
End If
Next
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
With Target
If InStr(1, .Address, ":") = 0 Then
OnChange1 Target, .Row, .Column, .Value
OnChange2 Target, .Row, .Column, .Value
End If
End With
Application.EnableEvents = True
End Sub
Private Function OnChange1(Target As Range, R&, C&, V)
Dim NichtLeer As Boolean, Wert#
On Error Resume Next
Select Case R
Case Is > 9, Is < 5
Exit Function
End Select
Select Case C
Case Is > 8, Is < 4
Exit Function
Case 4: If V = "x" Then Wert = 1
Case Else: If V = "x" Then Wert = 2
End Select
If V <> "" Then
Range(Cells(R, 4), Cells(R, 8)).ClearContents
Target.Value = "x"
End If
If Wert <> 0 Then
Cells(6 + R, 3) = Wert
Else
If Cells(R, 8).End(xlToLeft).Column < 4 Then
Cells(6 + R, 3) = ""
End If
End If
End Function
Private Function OnChange2(Target As Range, R&, C&, V)
Dim rng As Range, sumCell As Range
On Error Resume Next
Set sumCell = Cells(R, 11)
If R < 5 And R < 33 Or V = "" Then
sumCell = ""
Exit Function
End If
Select Case C
Case Is > 8, Is < 4: Exit Function
End Select
Set rng = Range(Cells(R, 4), Cells(R, 8))
rng.ClearContents
Target.Value = "x"
sumCell = (8 - C) * Cells(R, 3)
End Function