Aufrunden ab 1000er Stelle 1

18.01.2025 21:14:11

chris58

Hallo !
Bitte kann mir wer sagen, was ich im Code, denn ich zusammengestopelt habe, ändern muß.
Ich will, das, wenn in der Zelle der Betrag geändert wird, die 1000er Stelle ab 0,001 die 100er Stelle aufgerundet wird.
Also Beispiel: Eingabe 102,231 wird aufgerundet auf 102,24 ......... 1,253 wird aufgerundet auf 1,26.
Danke für Eure Hilfe
chris58

https://www.herber.de/bbs/user/174944.xls

AW: Aufrunden ab 1000er Stelle 1

18.01.2025 23:25:23

BoskoBiati2

Hi,

c.Value = WorksheetFunction.RoundUp(c.Value, 2)

Gruß

Edgar

AW: Aufrunden ab 1000er Stelle 1

19.01.2025 20:51:41

chris1958

Hallo !
Danke für den Code. Also der geht .................... ich habe nur ein Problem an dem ich zuerst versuchte es selbst zu erledigen - jedoch ohne Erfolg.
Ich habe eine UF die gibt in B6 ein und wird mit deinem Code (ingesamt mit meinem) aufgerundet eingetragen. Jedoch wird dann nicht die aufgerundete Zahl hinzugerechnet, sondern nur, der abgerundete. Hier der mein bisheriger Code mit dem neuen von Edgar.
Vielleicht gibts einen Helfer, der mir nochmals helfen kann.
Danke vielmals
chris58

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$7" Then
With Sheets("Berechnung") 'hier deinen Tabellennamen eingeben
.Range("C6") = .Range("C6") + .Range("B6")
.Range("B6").Select
End With
End If
If Target.Row = 6 And Target.Column = 2 Then
Dim c As Range
For Each c In Range("B6")
c.Value = WorksheetFunction.RoundUp(c.Value, 2)
Next c
End If
End Sub

Hier der Code von der UF, die die Gesamten Einträge in eine Liste einträgt.

Option Explicit
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
With Sheets("Berechnung") 'Hier musst du deinen Tabellennamen eingeben
Range("B6").Value = CDbl(TextBox1.Value) ' Du musst den Text in eine Zahl umwandeln. VBA erkennt das Komma als Tausender Trennzeichen
.Range("C6") = .Range("C6") + .Range("B6")
.Range("B6").Select
End With
End If
End Sub
Private Sub CommandButton5_Click()
UserForm1.TextBox4.SetFocus
Range("C17").Value = CDbl(TextBox4.Text)
End Sub
Private Sub CommandButton2_Click()
Unload Me
Range("A2").Select
End Sub
Private Sub CommandButton4_Click()
Dim i, j
Dim R As Range
Const cNeuesBlatt As String = "Berechnung"

'Prüfung. Wenn einer "ist nicht numerisch", dann raus
If (Not IsDate(TextBox3)) Or IstNichtNum(TextBox1) Or IstNichtNum(TextBox4) Or IstNichtNum(TextBox5) Or IstNichtNum(TextBox6) Or IstNichtNum(TextBox7) Then Exit Sub

'Es passiert alle auf ActiveSheet
Cells(6, "B") = CDbl(Format(TextBox1, "#,##0.00"))
Cells(7, "C") = CDate(TextBox3)

Application.ScreenUpdating = False
'Wert zum neuen Blatt übertragen
Set R = Blatt_selektieren(cNeuesBlatt).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow 'nächste leere Zeile ermitteln. R ist eine Zeile.
For Each i In Split("C7 C11 C6 C12 C13 C14")
j = j + 1
R.Cells(j) = Range(i).Value 'Cells(1) von einer Zeile in der Spalte A dieser Zeile, 2 B, 3 C, usw.
Next

R.Cells(Columns("H").Column) = CDbl(TextBox1) 'B6
R.Cells(Columns("L").Column) = CDbl(TextBox7) 'C21
R.Cells(Columns("J").Column) = CDbl(TextBox4) 'C17
R.Cells(Columns("K").Column) = CDbl(TextBox5) 'C18
R.Cells(Columns("I").Column) = CDbl(TextBox6) 'C19
R.Cells(Columns("N").Column) = ComboBox1 'C20

'Fromel einreichten
R.Cells(7).FormulaR1C1 = "=SUM(RC[1]+RC[4]-RC[2])" 'Formel in Spalte G: Gesamtverbrauch per Tag aus EVN & Einspeisung aus PV Anlage
R.Cells(8).FormulaR1C1 = "=(RC3-R[-1]C3)" 'Formel in Spalte H (relative Adressierung)
' =SUM(RC[1]+RC[4])
R.Cells(9).Interior.ColorIndex = 35 'Spalte I
' R.Cells(9).FormulaR1C1 = "=(RC[-1])/24"
R.Cells(13).Formula = "=TEXT(" & R.Cells(1).Address & ",""TTTT"")" 'Formel in Spalte M

'Färbung
R.Interior.Pattern = xlNone
R.Cells(5).Interior.ColorIndex = 36
R.Cells(7).Interior.ColorIndex = 34
R.Cells(9).Interior.ColorIndex = 35

'Abschluss
Range("A2").Select
Application.ScreenUpdating = True
Unload Me '--- Userform schließen

Dim raFund As Range
With ActiveSheet
Set raFund = .Columns(3).Find(What:="*", LookIn:=xlValues, LookAt:=xlWhole, _
searchdirection:=xlPrevious)
If Not raFund Is Nothing Then
Application.Goto .Cells(raFund.Row - 3, 1), True
End If
End With
Set raFund = Nothing
Range("A2").Select
End Sub
Private Sub UserForm_Initialize()
ComboBox1.AddItem " 1. Sonne/heiß/klarer Himmel"
ComboBox1.AddItem " 2. Sonne/warm/bewölkter Himmel"
ComboBox1.AddItem " 3. Regen/warm/wenig Sonne"
ComboBox1.AddItem " 4. Sonne/kalt/klarer Himmel"
ComboBox1.AddItem " 5. Sonne/kalt/bewölkter Himmel"
ComboBox1.AddItem " 6. Regen/kalt/wenig Sonne"
ComboBox1.AddItem " 7. Bewölkt/kalt/wenig Sonne"
ComboBox1.AddItem " 8. Bewölkt/kalt/Nebel/Schnee"
ComboBox1.AddItem " 9. Nebel/Akku ganz leer/Vortag ca 40%"
End Sub
Private Function Blatt_selektieren(ByVal BlattName As String) As Worksheet
Dim WS As Worksheet
'alles basiert auf ActiveWorkbook
On Error Resume Next
Set WS = Worksheets(BlattName)
If WS Is Nothing Then
Set WS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
WS.Name = BlattName
End If
Set Blatt_selektieren = Worksheets(BlattName)
End Function
Private Function IstNichtNum(TxtBx As Control) As Boolean
If Not IsNumeric(TxtBx.Text) Then
MsgBox "PV Einspeisung eigeben - oder 0!" '---> Meldung
TxtBx.SetFocus '---> Textbox aktivieren
IstNichtNum = True
End If
End Function

Und hier die Datei:
https://www.herber.de/bbs/user/174971.xls

AW: Aufrunden ab 1000er Stelle 1

20.01.2025 12:41:28

chris58

Hallo !
Ich habe nach mehreren Stunden das Problem gelöst.
Danke für die Zeit
chris58

AW: Aufrunden ab 1000er Stelle 1

19.01.2025 00:11:41

Yal

N' Abend Chris,

Die Google-suche lautet:
VBA aufrunden

Erste Treffer:
https://learn.microsoft.com/de-de/office/vba/language/reference/user-interface-help/round-function

So musst Du nicht 2 Stunden auf einer Antwort warten.

(Ich bevorzuge immer die Seiten von learn.microsoft.com, nicht weil sie besser sind, sondern weil sie immer nach dieselbe Struktur aufgebaut und somit schneller zu erfassen sind.)

VG
Yal

Aufrunden ab 1000er Stelle 1

Forumthread: Aufrunden ab 1000er Stelle 1

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Aufrunden ab 1000er Stelle 1

Forumthread: Aufrunden ab 1000er Stelle 1

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread