AW: Zahlen aus aus Text extrahieren und addieren
12.09.2008 13:56:36
Chris
Servus Bernd,
so:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim DatenArray() As Long, MIDArray() As Variant
Dim i As Long, x As Long, summe As Double, z As Long
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column 2 Then Exit Sub
If Target.Column = 2 And Target.Value = "" Then Target.Offset(0, 1) = "": Exit Sub
If Not Intersect(Target, Range("B:B")) Is Nothing Then
For i = 1 To Len(Target)
If IsNumeric(Mid(Target, i, 1)) Then
ReDim Preserve DatenArray(x)
ReDim Preserve MIDArray(x)
DatenArray(x) = i
MIDArray(x) = Mid(Target, i, 1)
x = x + 1
Else
If i > 1 Then
If Mid(Target, i, 1) = "," And IsNumeric(Mid(Target, i - 1, 1)) And IsNumeric(Mid(Target, _
i + 1, 1)) Then
ReDim Preserve DatenArray(x)
ReDim Preserve MIDArray(x)
DatenArray(x) = i
MIDArray(x) = Mid(Target, i, 1)
x = x + 1
End If
End If
End If
Next i
For i = LBound(DatenArray()) To UBound(DatenArray())
If DatenArray(i) - 1 0 Then
Select Case Mid(Target, DatenArray(i) - 1, 1)
Case "-":
MIDArray(i) = "-" & MIDArray(i)
End Select
End If
Next i
For i = LBound(DatenArray()) + 1 To UBound(DatenArray())
If DatenArray(i) = DatenArray(i - 1) + 1 Then
MIDArray(i) = MIDArray(i - 1) & MIDArray(i)
MIDArray(i - 1) = 0
End If
Next i
For i = LBound(MIDArray()) To UBound(MIDArray())
summe = summe + MIDArray(i)
Next i
Cells(Target.Row, 3) = summe
End If
End Sub
berücksichtigt jetzt auch Kommazahlen, was vorher nicht war.
Gruß
Chris