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
|