Hallo Mehoranto
probier das mal bitte.
Die Originalen Daten werden überschrieben.
Probleme würden Eintragen wie "12km mehr als 7" machen.
Vielleicht hilft das ja weiter
Gruß
Sub KM_ändern()
Dim WS As Worksheet
Set WS = ActiveSheet
Dim Zeichen As String
Dim zMax As Long
Dim Pos As Long
Dim Idx As Long
Dim TXT As String
Dim Daten As Variant
Zeichen = "0123456789,"
'letzte Zeile in der Spalte 'A' (1) suchen
zMax = WS.Cells(2 ^ 16, 1).End(xlUp).Row
'Von Zeile 2 bis zur letzten Zeile die Spalte 'A' (1) in das Array 'Daten' schreiben
Daten = WS.Range(WS.Cells(2, 1), WS.Cells(zMax, 1))
'Das Array 'Daten' vom ersten zum letzten Feld durchlaufen
For Idx = LBound(Daten, 1) To UBound(Daten, 1)
'Wenn keine Zahl drinsteht dann ...
If IsNumeric(Daten(Idx, 1)) = False Then
TXT = ""
'Durchlaufe gesamten Zellinhalt Zeichen für Zeichen
For Pos = 1 To Len(Daten(Idx, 1))
'Überprüfe jedes Zeichen mit erlaubten Zahlenzeichen (mit Komma)
If InStr(1, Zeichen, Mid(Daten(Idx, 1), Pos, 1), vbTextCompare) > 0 Then
'Erstelle eine Zeichenkette mit den gefundenen Zahlen
TXT = TXT & Mid(Daten(Idx, 1), Pos, 1)
End If
Next Pos
'Geänderte Zahl wieder in Array schreiben
'Ich addiere nur 0,1 und Runde die Zahl auf. Bei 5,7 ergibt das dann 6 und bei ganzen Zahlen eins mehr
Daten(Idx, 1) = Application.WorksheetFunction.RoundUp(CSng(TXT) + 0.1, 0)
End If
Next Idx
'Debug in Spalte 'B' (Hier die 2)
' WS.Range(WS.Cells(2, 2), WS.Cells(zMax, 2)) = Daten
'Originale Daten überschreiben
WS.Range(WS.Cells(2, 1), WS.Cells(zMax, 1)) = Daten
Set WS = Nothing
End Sub
|