Zahl in Ergebnis umwandeln

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RNG As Range, NeuWert As Variant, ZuWert As Integer Set RNG = Columns(1) On Error GoTo Fehler Const APPNAME = "Worksheet_Change" If Not Intersect(RNG, Target) Is Nothing And _ Target.Count = 1 Then If IsNumeric(Target) Then If Target.MergeCells Then ZuWert = IIf(Target >= 10, Target + 2, 11) With Application .EnableEvents = False Target.MergeCells = False Target.Cells(1, 2) = ":" Target.Cells(1, 3) = ZuWert .EnableEvents = True End With End If Else MsgBox "Fehler: Muss eine Zahl sein" End If End If '*** Fehlerbehandlung Err.Clear Fehler: Application.EnableEvents = True If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _ & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim RNG As Range, NeuWert As Variant, ZuWert As Integer Set RNG = Columns(1) On Error GoTo Fehler Const APPNAME = "Worksheet_Change" If Not Intersect(RNG, Target) Is Nothing And _ Target.Count = 1 Then If IsNumeric(Target) Then If Target.MergeCells Then ZuWert = IIf(Target >= 10, Target + 2, 11) NeuWert = Target With Application .EnableEvents = False Target.MergeCells = False Target.Cells(1, 1) = ZuWert Target.Cells(1, 2) = ":" Target.Cells(1, 3) = NeuWert .EnableEvents = True End With End If Else MsgBox "Fehler: Muss eine Zahl sein" End If End If '*** Fehlerbehandlung Err.Clear Fehler: Application.EnableEvents = True If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _ & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Private Sub Worksheet_Change(ByVal Target As Excel.Range) On Error GoTo Fehler Const APPNAME = "Worksheet_Change" '************** Normieren Ergebnisse Dim RNG As Range, NeuWert As Variant, ZuWert As Integer Set RNG = Range("S40:AG76") If Not Intersect(RNG, Target) Is Nothing Then If Target.Count 1 Then MsgBox "Fehler: Zellen einzeln ändern" GoTo Fehler End If If Not IsNumeric(Target) Then MsgBox "Fehler: Muß eine Zahl sein" GoTo Fehler End If If Target.MergeCells And Range(Target.MergeArea.Address).Count = 12 Then NeuWert = Target ZuWert = IIf(Abs(Target) >= 10, Target + 2, 11) With Application .EnableEvents = False .Calculation = xlCalculationManual '4x3 er Gruppierung aufheben Target.MergeCells = False '4er Grupierung 3x neu setzen Target.Resize(4, 1).MergeCells = True Target.Offset(0, 1).Resize(4, 1).MergeCells = True Target.Offset(0, 2).Resize(4, 1).MergeCells = True 'Doppelpunkt in Mitte Target.Cells(1, 2) = ":" If NeuWert >= 0 Then 'Positive Eingabe Target.Cells(1, 1) = ZuWert Target.Cells(1, 3) = NeuWert Else 'Negative Eingabe Target.Cells(1, 3) = ZuWert Target.Cells(1, 1) = -NeuWert End If .EnableEvents = True .Calculate End With Else MsgBox "Fehler: Verbunde Zellen?" End If End If '*** Fehlerbehandlung Err.Clear Fehler: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _ & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Hallo
zu 1 und 2)
Für Spiel 1-3 und 16 hast du jeweils 4 Zeilen verwendet und die in je 3 Spalten zusammen verbunden. (also 12 Zellen)
Genau auf diese 12 Zellen prüft das Makro
Die anderen Spiele sind nur je 2 zeilig. Da blende ich dann die Meldung ein.
Abhilfe:
Alle Spiele gleich aufbauen
oder Makro aufbohren
zu 3) ok. das kann man Ändern
Abhilfe:
das Gleichheitszeichen weglassen


If NeuWert >=0 Then 'Positive Eingabe

zu 4) Das Kombinieren und Trennen von Zellen ist eine Formatänderung. Die hast du aber beim Sperren des Blattes nicht zugelassen
Abhilfe:
den Haken bei "Zellen formatieren" anklicken
zu 5) du hast auf dem Baltt über 150 bedingte Formatierungsregeln eingebaut.
Sorry, aber da sehe ich nicht nach.
Auf den ersten Blick kannst du da einige löschen (Ausgeblendete Zellen brauchen keine Bed. Formatierung) oder zusammenfassen
Nur ein Beispiel: aus 3 Bedingungen
Formel:


$BE$41=1
$BE$41=2
$BE$41=3

Geht eine Bedingung
Formel:


$BE$41>=1 * $BE$41

LG UweD

Hallo
Eine Eingabe von -0 wird von Excel sofort zu 0 umgewandelt, da es kein negatives Null gibt.
Ausweg:
- Die Eingabezellen müssen als Text formatiert sein.
- Mit dem nun abgeänderten Makro wird das Minus vorne erkannt.
- Auch habe ich die Prüfung auf 12er und 6er Zellverbund eingebaut


Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'    If Target.Address = Range("BX2") Then
'        Call Modul3.LeerzeilenLoeschen_2
'    End If
ActiveSheet.Unprotect
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
'************** Normieren Ergebnisse
Dim RNG As Range, NeuWert As Variant, ZuWert As Integer
Dim VZ As Boolean, Mcount As Integer
Set RNG = Range("S40:AG100")
If Not Intersect(RNG, Target) Is Nothing Then
If Target.Count  1 Then
MsgBox "Fehler: Zellen einzeln ändern"
GoTo Fehler
End If
If Not IsNumeric(Target) Then
MsgBox "Fehler: Muß eine Zahl sein"
GoTo Fehler
End If
Mcount = Range(Target.MergeArea.Address).Count
If Target.MergeCells And (Mcount = 12 Or Mcount = 6) Then
NeuWert = Target
ZuWert = IIf(Abs(Target) >= 10, Abs(Target) + 2, 11)
VZ = IIf(Left(Target.Text, 1)  "-", True, False) 'Vorzeichen
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
'Gruppierung  aufheben
Target.MergeCells = False
If Mcount = 12 Then
'4er Grupierung 3x neu setzen
Target.Resize(4, 1).MergeCells = True
Target.Offset(0, 1).Resize(4, 1).MergeCells = True
Target.Offset(0, 2).Resize(4, 1).MergeCells = True
ElseIf Mcount = 6 Then
'2er Grupierung 3x neu setzen
Target.Resize(2, 1).MergeCells = True
Target.Offset(0, 1).Resize(2, 1).MergeCells = True
Target.Offset(0, 2).Resize(2, 1).MergeCells = True
End If
'Doppelpunkt in Mitte
Target.Cells(1, 2) = ":"
If VZ Then  'Positive Eingabe
Target.Cells(1, 1) = ZuWert
Target.Cells(1, 3) = NeuWert
Else 'Negative Eingabe
Target.Cells(1, 3) = ZuWert
Target.Cells(1, 1) = -NeuWert
End If
.EnableEvents = True
.Calculate
End With
Else
MsgBox "Fehler bei Verbunden Zellen! Keine 12er oder 6er Blöcke"
End If
End If
ActiveSheet.Protect
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
If Err.Number  0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

319 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zahl in Ergebnis umwandeln

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

319 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread