getrennt in Spalten...
21.12.2009 19:07:23
Tino
Hallo,
geht etwas einfacher.
Teste mal.
Enum EnumPattern
Zahlen_ = 0
Text_ = 1
End Enum
Sub ArTrenneTextZahl(strText$, meAr, sPattern As EnumPattern)
Dim objMatch As Object, objRegEx As Object
Dim A As Long, AA As Long, tmpAr()
Dim Korrektur As Long
Dim strPattern$
Const sZahlen$ = "[0-9]{1,},?[0-9]{0,}"
Const sText$ = "\D{2,}"
strPattern$ = IIf(sPattern = Text_, sText, sZahlen)
Set objRegEx = CreateObject("VBScript.RegExp")
With objRegEx
.MultiLine = True
.Global = True
.IgnoreCase = True
.Pattern = strPattern
Set objMatch = .Execute(strText)
End With
If Not objMatch Is Nothing Then
Redim Preserve tmpAr(objMatch.Count - 1)
For Each objMatch In objMatch
If IsNumeric(objMatch) Then
tmpAr(A) = objMatch * 1
Else
tmpAr(A) = objMatch
End If
A = A + 1
Next objMatch
End If
meAr = tmpAr
End Sub
Sub Test_Text_Zahlen_Trennen()
Dim meArText, meArZahlen
Dim strText$
Dim A&
'Kommentar auslesen in einen String
strText = Range("B1").Comment.Text
If (strText Like "*#*") Then
ArTrenneTextZahl strText, meArZahlen, Zahlen_
End If
If (strText Like "*[A-Z]*") Then
ArTrenneTextZahl strText, meArText, Text_
End If
'ab A2 leer machen für neue Daten (A1= Überschrift)
Range("A2").Resize(Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
Range("B2").Resize(Cells(Rows.Count, 2).End(xlUp).Row + 2).ClearContents
If IsArray(meArText) Then
Range("A2").Resize(Ubound(meArText) + 1) = Application.Transpose(meArText)
End If
If IsArray(meArZahlen) Then
Range("B2").Resize(Ubound(meArZahlen) + 1) = Application.Transpose(meArZahlen)
End If
End Sub
Gruß Tino