Public Sub cmd_Simultanität_aus_Click()
Dim rngAuswahl As Range, c As Range
Dim objRangeCollection As Collection
Application.DisplayAlerts = False
Set objRangeCollection = New Collection
Do
objRangeCollection.Add Application.InputBox(Prompt:= _
"Bitte die Zelle(n) markieren, deren Simultanität geändert werden soll:", Title:="Auswahl", Type:=8)
If TypeOf objRangeCollection(objRangeCollection.Count) Is Range Then
Set rngAuswahl = objRangeCollection(objRangeCollection.Count)
Exit Do
ElseIf IsEmpty(objRangeCollection(objRangeCollection.Count)) Then
MsgBox "Objektzuweisung fehlgeschlagen. Bitte nochmal versuchen", _
vbCritical, "Fehlermeldung"
ElseIf Not objRangeCollection(objRangeCollection.Count) Then
Application.DisplayAlerts = True
Exit Sub
Else
MsgBox "Fehler " & CStr(vbObjectError) & vbLf & vbLf & _
"Unbekannter Objektfehler beim zuweisen eines Bereiches.", _
vbCritical, "Fehlermeldung"
Application.DisplayAlerts = True
Exit Sub
End If
Loop
If rngAuswahl.Rows.Count > 1 Then
MsgBox "Bitte wählen Sie nur ein Equipment / eine Anlage aus.", vbCritical
Exit Sub
End If
For Each c In rngAuswahl.Cells
If c.Column <= 6 Then
If IsNumeric(c.Value) And Not IsEmpty(c.Value) Then
If UCase(Cells(c.Row, 7).Value) <> "X" Then
MsgBox "Bitte wählen Sie erst die gesamte Zeile simultan.", vbCritical
Exit Sub
End If
If c.Font.ColorIndex <> 16 Then
c.Font.ColorIndex = 16
Range("A6").Value = "Gebäude"
ElseIf c.Font.ColorIndex = 16 Then
c.Font.ColorIndex = xlAutomatic
Range("A6").Value = "Gebäude"
End If
End If
ElseIf c.Column = 8 Then
If IsNumeric(c.Value) And Not IsEmpty(c.Value) Then
If UCase(Cells(c.Row, 7).Value) <> "X" Then
MsgBox "Bitte wählen Sie erst die gesamte Zeile simultan.", vbCritical
Exit Sub
End If
If c.Font.ColorIndex <> 16 Then
c.Resize(1, 3).Font.ColorIndex = 16
Range("A6").Value = "Gebäude"
ElseIf c.Font.ColorIndex = 16 Then
ActiveSheet.Unprotect Password:=""
c.Resize(1, 3).Font.ColorIndex = xlAutomatic
Range("A6").Value = "Gebäude"
End If
End If
End If
Next c
Application.DisplayAlerts = True
End Sub