AW: textkette
02.05.2011 20:19:50
fcs
Hallo Hans,
hier eine VBA-Makro-Lösung.
Makro in ein allgemeines Modul im VBA-Editor einfügen.
In Tabelle Cursor auf die Zelle mit dem Text positionieren. Dann Makro starten.
Dabei muss die Syntax:
Sie haben verloren: FigurX 99, FigurY 11, FigurZ 41. Sie haben getötet: FigurA 33, FigurB 2, FigurC 325
eingehalten werden. Wichtig sind:
"." als Trenzeichen für Daten in linker/rechter Spalte
":" als Trennzeichen zwischen Spaltentitel und Daten
"," als Trennzeichen zwischen den Datenzeilen
" " als Trennzeichen zwischen dem Fifugurnamen und der Anzahl
Gruß
Franz
'Erstellt unter Excel 2007
Sub Textaufteilen()
Dim Zelle As Range, arrText1, arrText2, iI As Long, iOffset As Long
Dim sText As String
On Error GoTo Fehler
Set Zelle = ActiveCell 'Zelle mit dem aufzuteilenden Text
'Textteile werden in Zelle beginend nach unten eingetragen
sText = Zelle.Text
If sText = "" Or InStr(1, sText, ":") = 0 Or InStr(1, sText, ".") = 0 Then
MsgBox "Text ist leer oder enthält nicht "":"" oder ""."""
GoTo Fehler
End If
Zelle.Parent.Range(Zelle, Zelle.Offset(20, 3)).ClearContents '20 max. Anzahl Zeilen, _
die ausgefüllt werden könnten
'Text am Punkt aufteilen
arrText1 = Split(sText, ".")
'1. Textteil am ":" aufteilen
arrText2 = Split(arrText1(0), ":")
iOffset = 0
'1. Teil des 1. Textteils eintragen
Zelle.Offset(iOffset, 0) = Trim(arrText2(0)) & ":"
'2. Teil des 1. Textteils am "," teilen
arrText2 = Split(Trim(arrText2(1)), ",")
'Bezeichnungen und Anzahl aus 1. Textteil eintragen
For iI = 0 To UBound(arrText2)
iOffset = iOffset + 1
If InStr(1, arrText2(iI), " ") > 0 Then
'Bezeichnung Eintragen
Zelle.Offset(iOffset, 0) = Trim(Left(arrText2(iI), InStrRev(arrText2(iI), " ") - 1))
'Anzahl eintragen
Zelle.Offset(iOffset, 1) = Val(Trim(Mid(arrText2(iI), InStrRev(arrText2(iI), " ") + 1)))
Else
Zelle.Offset(iOffset, 0) = Trim(arrText2(iI))
End If
Next
'2. Textteil am ":" aufteilen
arrText2 = Split(arrText1(1), ":")
iOffset = 0
'1. Teil des 2. Textteils eintragen
Zelle.Offset(iOffset, 2) = Trim(arrText2(0)) & ":"
'2. Teil des 2. Textteils am "," teilen
arrText2 = Split(Trim(arrText2(1)), ",")
For iI = 0 To UBound(arrText2)
iOffset = iOffset + 1
If InStr(1, arrText2(iI), " ") > 0 Then
'Bezeichnung Eintragen
Zelle.Offset(iOffset, 2) = Trim(Left(arrText2(iI), InStrRev(arrText2(iI), " ") - 1))
'Anzahl eintragen
Zelle.Offset(iOffset, 3) = Val(Trim(Mid(arrText2(iI), InStrRev(arrText2(iI), " ") + 1)))
Else
Zelle.Offset(iOffset, 2) = Trim(arrText2(iI))
End If
Next
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub