noch eine Variante
28.11.2010 12:34:55
Tino
Hallo,
habe hier auch mal eine Version zusammengebastelt.
Sub Extrahiere_Zahlen()
Dim strData$, ArrayAusgabe(), varInhalt
Dim Regex As Object, objMatch As Object
Dim nCount&
Const sZahlen$ = "\d+,\d+|\d+"
With Tabelle1 'Tabelle anpassen
nCount = .Cells(.Rows.Count, 3).End(xlUp).Row 'letzte Zeile in Spalte 3
If nCount < 7 Then 'keine Daten im Bereich?
MsgBox "keine Daten ab C7!"
Exit Sub
End If
If nCount > 7 Then
strData = Join(Application.Transpose(.Range("C7", .Cells(nCount, 3)).Value2), "@")
Else
strData = .Range("C7").Value
End If
nCount = 0
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.MultiLine = True
.Pattern = sZahlen
.Global = True
Set objMatch = .Execute(strData)
End With
If objMatch.Count > 0 Then
Redim Preserve ArrayAusgabe(objMatch.Count - 1)
For Each objMatch In objMatch
ArrayAusgabe(nCount) = CSng(objMatch.Value)
nCount = nCount + 1
Next objMatch
End If
'Bereich leer machen für neue Daten
.Range("E7:E" & .Rows.Count).ClearContents
If nCount > -1 Then
With .Range("E7").Resize(nCount)
.Value = Application.Transpose(ArrayAusgabe)
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
End With
End If
End With
End Sub
Gruß Tino