Hallo liebe Mitglieder,

Ich habe ein Problem und hoffe auf Hilfe!

Es betrifft ca. 800 Zeilen und ich möchte das über einen cleveren Makrocode lösen, nur leider bin ich für diesen nicht so clever.

Wenn ich in den jeweiligen Zellen (I19, J19, K19) Werte mit unterschiedlichen Dezimalstellen (Nachkommastellen) eingebe, dann sollen die Werte in den Zellen (W19, X19, Y19) unterschiedliche Werte annehmen.

I19 ist dabei W19, J19 ist X19 und K19 ist Y19 zugeordnet.

Dieses Makro möchte ich dann auf alle Zeilen zwischen 19 und 803 erweitern können.

Für die Eingabe einer Zahl mit keiner Dezimalstelle, soll die zugeordnete Zelle den Wert 7 annehmen.

Für die Eingabe mit einer Dezimalstelle den Wert 5.

Für die Eingabe mit zwei Dezimalstellen den Wert den Wert 3.

Für die Eingabe mit drei Dezimalstellen den Wert 2.

Für die Bezugszellen in den Spalten I, J, K gibt es allerdings ein aktives Makro, welches aber wahlweise dennoch funktionieren soll. Es handelt sich dabei um einen DoubleClick und RightClick-Sub, mit dem man die Werte in den Bezugsquellen wahlweise zwischen 2 und 7 in einer Schleife durch hoch- und runterklicken ändern kann.

Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)

Dim arrA() As String, x
Dim rngSh1 As Range, c As Range

If target.Count > 1 Then Exit Sub

' Shaft(1-19)_regular (up)

arrA = Split("P19:P803,R19:R803,U19:U803", ",")
For x = LBound(arrA) To UBound(arrA)
   If rngSh1 Is Nothing Then
      Set rngSh1 = Range(arrA(x))
   Else
      Set rngSh1 = Union(rngSh1, Range(arrA(x)))
   End If
Next x

If Not Intersect(rngSh1, target) Is Nothing Then
   
   Application.EnableEvents = False
      target.Value = target.Value + 1
      Application.EnableEvents = True
      Cancel = True
      Exit Sub
      
End If

' Shaft(1-19)_regular_tolerances (up)

arrA = Split("W19:W803,X19:X803,Y19:Y803", ",")
For x = LBound(arrA) To UBound(arrA)
   If rngSh1 Is Nothing Then
      Set rngSh1 = Range(arrA(x))
   Else
      Set rngSh1 = Union(rngSh1, Range(arrA(x)))
   End If
Next x

If Not Intersect(rngSh1, target) Is Nothing Then
   
   Application.EnableEvents = False
      Doit target
      Application.EnableEvents = True
      Cancel = True
      Exit Sub
      
End If

End Sub

Private Sub Doit(target)
Dim c As Range
    
   Set c = target
   If VarType(c.Value) = 5 Then
      Select Case Int(c.Value)
         Case Is < 1, 7
            c.Value = 2
         Case Else
            c.Value = c.Value + 1
      End Select
   Else
      c.Value = 2
   End If
   
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal target As Range, Cancel As Boolean)

Dim arrA() As String, x
Dim rngSh1 As Range, c As Range

If target.Count > 1 Then Exit Sub

' Shaft(1-19)_regular (down)

arrA = Split("P19:P803,R19:R803,U19:U803", ",")
For x = LBound(arrA) To UBound(arrA)
   If rngSh1 Is Nothing Then
      Set rngSh1 = Range(arrA(x))
   Else
      Set rngSh1 = Union(rngSh1, Range(arrA(x)))
   End If
Next x

If Not Intersect(rngSh1, target) Is Nothing Then
   
   Application.EnableEvents = False
      target.Value = target.Value - 1
      Application.EnableEvents = True
      Cancel = True
      Exit Sub
      
End If

End Sub