Daten trennen bei numerischen Wert?!?

Hallo !
Ich stehe hier vor einem Problem und weiß ehrlich nicht genau, wo ich das Problem beim Schopfe packen soll.
Also, ich erhalte Fahrzeugangaben, die wie folgt aussehen:
PD11 X3 2.0d der BMW AG / Fahrzeugherkunft: Fuhrparkfahrzeug
Fahrgestell-Nummer: WBAPD110X0 WH69464 Hubraum: 1995
EZ/ Produktionsdatum: 22.08.2007/ 20.08.2007 kW/ PS: 110/ 150
Kilometer-Stand: 15.289 Abmeldung: 26.05.2008
Farbe:
0475, saphirschwarz
metallic
Polster:
LUAZ, Leder Nevada
Terracotta
Sonderausstattung:
01CA Selektion CO2 relevanter Fahrzeuge 0200 Diesel Partikelfilter
0216 Servotronic 0240 Fahrerairbag mit Lederkranz
0249 Multifunktion für Lenkrad inklusive
Geschwindigkeitsregelung
02R5 Leichtmetallräder Sternspeiche 204
0302 Alarmanlage mit Fernbedienung 0321 Exterieurumfänge in Wagenfarbe
0358 Klimakomfort-Frontscheibe 0386 Dachreling
0402 Panorama-Glasdach elektrisch 0413 Gepäckraumtrennnetz
0423 Fußmatten in Velours 0428 Warndreieck
0430 Innen- und Außenspiegel automatisch
abblendend
0431 Innenspiegel automatisch abblendend
0464 Skisack 0473 Armauflage vorn
0493 Ablagenpaket 0494 Sitzheizung für Fahrer und Beifahrer
04BZ Interieurleisten Titan hell 0502 Scheinwerfer-Waschanlage
0508 Park Distance Control (PDC) 0520 Nebelscheinwerfer
0521 Regensensor und automatische
Fahrlichtsteuerung
0522 Xenon-Licht
0534 Klimaautomatik 0548 Kilometertacho
0550 Bordcomputer 0606 Navigationssystem Business
0644 Handyvorbereitung mit Bluetooth
Schnittstelle
0672 CD Wechsler 6-fach
0676 HiFi Lautsprechersystem 0785 Blinkleuchten weiß
0801 Deutschland-Ausführung 0851 Sprachversion Deutsch
0863 Service Kontakt-Flyer Europa 0877 Entfall Überkreuzbedienung
0879 Deutsch/Betriebsanleitung/Serviceheft 08SP CO2 Steuerung
0934 Winterreifen auf Leichtmetallrädern 0936 BMW Handy bei Auslieferung anfordern
0964 Navi DVD bei Auslieferung anfordern 0981 Comfort Paket Plus
Bemerkung:
Reparierte Vorschäden: EUR 0,00 Schadensdaten Leitfaden für Reklamationen
Offene Schäden: EUR 658,90
Neupreis: EUR 43.222,00 Angebotspreis: EUR 29.502,00
Ich habe auch mal eine Exceldatei mit den gleichen Daten angehängt.

Die Datei https://www.herber.de/bbs/user/55550.xls wurde aus Datenschutzgründen gelöscht

Mein Problem ist nun, die relevanten Daten herauszufiltern. Die Daten bis zum Punkt Sonderausstattung: und ab Bermerkung: sind dabei nicht das Problem, sondern die Daten, die nach Sonderausstattung: kommen sind das Problem. Die Daten fangen immer mit einer Nummer an und dann kommt die Sonderausstattung. Das Ganze dann 2x in einer Zeile.
Das ist nun mein Problem. Wie kann ich die Daten der Sonderausstattung trennen, so dass ich die Texte der Sonderausstattung erhalte.
Eine Idee von mir war, nach dem numerischen Wert in den Fließtext zu suchen und das was zwischen den numerischen Werten steht ist dann die Sonderausstattung. Allerdings weiß ich nicht so ganz, wie ich das anstellen soll.
Als Lösung sollte eine VBA-Lösung zum Einsatz kommen, da ich mir ein kleines Makro erstellen möchte, dass mir diese Daten so auftrennt, dass ich vernünftige Fahrzeugdaten erhalte, da ich diese Daten mehrfach am Tag erhalte und diese in eine DB einpflegen muss.
Ich hoffe, jemand hat eine zündende Idee, bzw. Lösung für mich.
Danke Euch schon mal für die Hilfe,
Kasimir

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim i As Long, k As Long, lngLetzte As Long, j As Long Dim PosArray As Variant, Index As Variant, strZusammen As String lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) ' _ letzte Zeile in Spalte A For i = 1 To lngLetzte ' Schleife über 1 bis letzte Index = Split(Cells(i, 1), " ") ' Zellinhlat aufsplitten über Leerzeichen und in Array _ schreiben For k = LBound(Index) To UBound(Index) 'Schleife über erhaltenes Array If Left(Index(k), 1) = 0 Then ' Abfrage, ob TeilArray mit 0 anfängt, da alle _ Seriennummern mit 0 anfangen, hier könnte man auch IsNumeric verwenden, um den Bereich zu erweitern (Seriennummern ohne 0 am Anfang) If IsNumeric(Index(k)) And Index(k) Like "*,*" Then ' Abfrage, ob eine echte Zahl a _ la 12,78 oder so, wenn ja mach nichts, sonst ' do nothing Else Index(k) = "#" 'ersetzte die Zahl durch # End If End If Next k strZusammen = Index(0) & " " ' String neu zusammensetzten For k = LBound(Index) + 1 To UBound(Index) strZusammen = strZusammen & " " & Index(k) Next k Index = Split(strZusammen, "#") ' statt 0245 & Text steht jetzt # & Text, wieder nach # _ trennen j = 1 ' Spaltenindex For k = LBound(Index) To UBound(Index) ' Zellinhalt schreiben If Index(k) "" Then Cells(i, 1 + j) = Trim(Index(k)) ' Leerzeichen am Anfang und Ende entfernen j = j + 1 ' Spalte erweitern End If Next k Next i End Sub

Sub test() Dim zeile As Long, x() As String, intIndex As Integer, strTemp As String Dim strAusname As String strAusnahme = "-" For zeile = 12 To 41 strTemp = "" x = Split(Cells(zeile, 1), " ") If UBound(x) > 0 Then For intIndex = 0 To UBound(x) If Not IsNumeric(Left(x(intIndex), 1)) Or InStr(x(intIndex), strAusnahme) Then strTemp = strTemp & " " & x(intIndex) End If Next Cells(zeile, 2) = Mid(strTemp, 2) Else Cells(zeile - 1, 2) = Cells(zeile - 1, 2) & " " & Cells(zeile, 1) End If Next End Sub

Sub test() Dim Zelle1 As Range, Zelle2 As Range Dim SA_Text As String Dim SA_Liste() Dim SA_arr Dim TeilTexte() As String Dim i As Long, k As Long '--- Anfang und Ende der SAs ermitteln Set Zelle1 = Columns(1).Find(what:="Sonderausstattung:", lookat:=xlWhole, LookIn:=xlValues) Set Zelle2 = Columns(1).Find(what:="Bemerkung:", lookat:=xlWhole, LookIn:=xlValues) '--- SA-Texte in eine Gesamtvariable schreiben SA_arr = Range(Zelle1.Offset(1, 0), Zelle2.Offset(-1, 0)) For i = 1 To UBound(SA_arr) SA_Text = SA_Text & SA_arr(i, 1) & " " Next '--- SA-Text aufsplitten in einzelbestandteile (Trennzeichen ist Leerzeichen TeilTexte = Split(SA_Text, " ") '--- Daten analysieren, für jede SA eine neue Zeile anlegen und SA-Text wieder '--- Zusammensetzen '--- Bedingung für neue SA: 1. Zeichen numerisch und Text genau 4 Zeichen lang For i = 0 To UBound(TeilTexte) If IsNumeric(Left$(TeilTexte(i), 1)) And Len(TeilTexte(i)) = 4 Then k = k + 1 ReDim Preserve SA_Liste(1 To 2, 1 To k) SA_Liste(1, k) = TeilTexte(i) Else SA_Liste(2, k) = SA_Liste(2, k) & " " & TeilTexte(i) End If Next '--- Text bereinigen, Leerzeichen an Anfang und Ende eleminieren For i = 1 To k SA_Liste(2, i) = Trim(SA_Liste(2, i)) Next '--- Alte SA-Liste Löschen und neue SA-Liste einfügen Range(Zelle1.Offset(1, 0), Zelle2.Offset(-1, 0)).EntireRow.Delete Zelle1.Offset(1, 0).Resize(k, 1).EntireRow.Insert With Zelle1.Offset(1, 0).Resize(k, 2) .NumberFormat = "@" .Value = WorksheetFunction.Transpose(SA_Liste) End With End Sub

Hi
das geht im Prinzip auch, ist aber nicht so ganz einfach, weil hier keine klaren Definitonen vorhandnen sind, woran man erkennen kann, was Datenfeldbennenung und was Inhalt ist.
ich hab mal was versucht, aber die Daten müssen im Prinzip immer so vorliegen, sonst klappts nicht:
( dh. es dürfen nur die Bezeichnungen als Zweites Datenfeld innerhalb einer Zeile vorkommen, die im Array bei For Each txt in Array ("...", "...") aufgelistet sind, es können weniger sein, aber keine anderen.)


Sub test()
Dim Zelle1 As Range, Zelle2 As Range
Dim SA_Text As String
Dim SA_Liste()
Dim SA_arr
Dim TeilTexte() As String
Dim i As Long, k As Long
Dim txt
'--- Fahrzeugdaten und Bemerkungen auftrennen
For Each txt In Array("Angebotspreis", "Fahrzeugherkunft", "Hubraum", "kW/ PS", "Abmeldung")
Set Zelle1 = Columns(1).Find(what:=txt, Lookat:=xlPart, LookIn:=xlValues)
If Not Zelle1 Is Nothing Then
With Zelle1
.Offset(1, 0).Insert shift:=xlDown
.Offset(1, 0).Value = Mid$(.Value, InStr(.Value, txt))
.Value = Left(.Value, InStr(.Value, txt) - 2)
End With
End If
Next
'--- Farbe und Lack zusammenfassen
Set Zelle1 = Columns(1).Find(what:="Farbe:")
Set Zelle2 = Columns(1).Find(what:="Polster:")
For i = Zelle2.Row - 1 To Zelle1.Row + 1 Step -1
Cells(i - 1, 1).Value = Cells(i - 1, 1).Value & " " & Cells(i, 1).Value
Cells(i, 1).Delete shift:=xlUp
Next
Set Zelle1 = Columns(1).Find(what:="Polster:")
Set Zelle2 = Columns(1).Find(what:="Sonderausstattung:")
For i = Zelle2.Row - 1 To Zelle1.Row + 1 Step -1
Cells(i - 1, 1).Value = Cells(i - 1, 1).Value & " " & Cells(i, 1).Value
Cells(i, 1).Delete shift:=xlUp
Next
'--- Fahrzeugdaten und Bemerkungen aufsplitten
Columns(1).Replace ": ", ":"
Columns(1).TextToColumns _
Destination:=Range("A1"), _
DataType:=xlDelimited, _
Other:=True, OtherChar:=":"
'--- Anfang und Ende der SAs ermitteln
Set Zelle1 = Columns(1).Find(what:="Sonderausstattung", Lookat:=xlWhole, LookIn:=xlValues)
Set Zelle2 = Columns(1).Find(what:="Bemerkung", Lookat:=xlWhole, LookIn:=xlValues)
'--- SA-Texte in eine Gesamtvariable schreiben
SA_arr = Range(Zelle1.Offset(1, 0), Zelle2.Offset(-1, 0))
For i = 1 To UBound(SA_arr)
SA_Text = SA_Text & SA_arr(i, 1) & " "
Next
'--- SA-Text aufsplitten in einzelbestandteile (Trennzeichen ist Leerzeichen
TeilTexte = Split(SA_Text, " ")
'--- Daten analysieren, für jede SA eine neue Zeile anlegen und SA-Text wieder
'--- Zusammensetzen
'--- Bedingung für neue SA: 1. Zeichen numerisch und Text genau 4 Zeichen lang
For i = 0 To UBound(TeilTexte)
If IsNumeric(Left$(TeilTexte(i), 1)) And Len(TeilTexte(i)) = 4 Then
k = k + 1
ReDim Preserve SA_Liste(1 To 2, 1 To k)
SA_Liste(1, k) = TeilTexte(i)
Else
SA_Liste(2, k) = SA_Liste(2, k) & " " & TeilTexte(i)
End If
Next
'--- Text bereinigen, Leerzeichen an Anfang und Ende eleminieren
For i = 1 To k
SA_Liste(2, i) = Trim(SA_Liste(2, i))
Next
'--- Alte SA-Liste Löschen und neue SA-Liste einfügen
Range(Zelle1.Offset(1, 0), Zelle2.Offset(-1, 1)).Delete shift:=xlUp
Zelle1.Offset(1, 0).Resize(k, 2).Insert shift:=xlDown
With Zelle1.Offset(1, 0).Resize(k, 2)
.NumberFormat = "@"
.Value = WorksheetFunction.Transpose(SA_Liste)
End With
End Sub

Gruß, Daniel

Beliebteste Forumthreads (12 Monate)

Daten trennen bei numerischen Wert?!?

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten trennen bei numerischen Wert?!?

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread