Zelleninhalt auf mehrere Zellen splitten

Hallo,
ich stehe vor einer ziemlich schwierigen Aufgabe. Dabei geht es darum die Inhalte einer Zelle auf mehrere Zellen aufzusplitten. Ein System gibt mir folgende Strings für einzelne Aufträg in Zellen einer Spalte einer Tabelle aus:
"##LE1#AA10#AB20#ADU30#AR9#DD100##LE2#ZQ40#ADU20#AR90#DD10"
"##LE3#AB12#ZPN001##LE5#FG20#AA7"
-&gt Dabei steht LE1 für Level 1 (LE2 entsprechend für Level 2)
-&gt AA, AB, ADU, AR,DD... usw. stehen für verschiedene Produkte.
-&gt Die dahinter angegebenen Zahlen stellen Prozentzahlen dar und können von 1 - 100, aber auch von 001 - 100 variieren.
-&gt# stellt immer das Trennzeichen zwischen den Produkten dar (immer vorangestellt)
-&gt## stellt immer das Trennzeichen zum Level dar (immer vorangestellt)
Die Tabelle sieht dann ungefähr so aus:
Tabelle1

	A	B	C	D	E	F	G
23	Auftrag	String
24	U-A001	##LE1#AA10#AB20#ADU30#AR9#DD100##LE2#ZQ40#ADU20#AR90#DD10
25	U-A002	##LE3#AB12#ZPN001##LE5#FG20#AA7

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Falls notwendig ist es mir möglich die Formatierung des Strings bezüglich Reihenfolge oder Trennzeichen zu ändern (Ich könnte also Alternativen für die # integrieren.) Allerdings ist es zwingend notwendig, dass er in gewisser Weise gut zu lesen und demnach auch strukturiert ist. Als Zieltabelle möchte ich nun folgendes Vorfinden:
Tabelle1

	A	B	C	D	E	F	G	H	I	J
4	Auftrag	Level	Produkte
5			Produkt 1	Produkt 2	Produkt 3	Produkt 4	Produkt 5	Produkt 6	Produkt 7	Produkt 8
6			AA	AB	ADU	AR	DD	FG	ZPN	ZQ
7	U-A001	LE1	10	20	30	9	100
8		LE2			20	90	10			40
9		LE3
10		LE4
11		LE5
12	U-A002	LE1
13		LE2
14		LE3		12					1
15		LE4
16		LE5	7					20

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Falls es nicht möglich ist die Zieltabelle automatisch zu generieren, wäre es für mich auch keine Problem ein wenig mehr Zeit aufzuwenden, um dann eine Zieltabelle mit einzelnen Abfrageformeln zu erstellen. Wichtig ist mir vor allem, dass die Übertragung der Werte automatisch funktioniert und nicht mehr von Hand vorgenommen werden muss.
Ich hoffe, dass ich hier ein paar kreative Köpfe finde. Auf jeden Fall schon mal vielen Dank für Euer Interesse.
Gruß Felix

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo, Felix,
Du berichtest vom stundenlangen probieren. Wie gehst Du den die Sache an? Ich meine es birgt eine Schwierigkeit, dass Deine Einschätzung zu Deinem VBA-Level mit "nein" angegeben ist.
M.E. kannst Du Dein Problem nur mit VBA lösen und ich kann Dir allenfalls eine Arbeitsvorlage (nachfolgende Programmteile in eine Standard-Modul eifügen) gegeben, die Du Deinen Aufgaben entsprechen anpassen und erweitern müßtest.
Dim wsPT As Worksheet, ProduktName As Variant, r0 As Long Sub ErstelleProduktTabelle() Dim wsListe As Worksheet, strListe As String On Error Resume Next Set wsListe = Worksheets("Liste") If wsListe Is Nothing Then Exit Sub End If r = 2 With wsListe While Left(.Cells(r, 1), 3) = "U-A" Einrichten wsPT.Cells(r0, 1) = .Cells(r, 1) strListe = .Cells(r, 2) Zerlege strListe r = r + 1 Wend End With Set wsListe = Nothing Set wsPT = Nothing End Sub Sub Zerlege(strListe) Dim level As Integer, ipos As Integer Dim strPN As String, c As Integer With wsPT While Len(strListe) > 0 If Left(strListe, 4) = "##LE" Then 'Leveleintrag level = Val(Mid(strListe, 5)) ipos = InStr(5, strListe, "#") If ipos > 0 Then strListe = Mid(strListe, ipos) Else strListe = "" End If Else If Left(strListe, 1) <> "#" Then MsgBox "Fehler im Produkt-Reststring " & strListe Exit Sub Else 'Produkt gefunden strListe = Mid(strListe, 2) 'entferne # 'lese Produktnamen strPN = "" While Val(strListe) = False And Len(strListe) > 0 strPN = strPN + Left(strListe, 1) strListe = Mid(strListe, 2) Wend 'suche nach Produktname im Spaltenkopf c = wsPT.Range("C3:J3").Find(What:=strPN, _ After:=wsPT.Range("C3"), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ MatchCase:=True).Column If c < 1 Then 'neuer Wert :=> neue Spalte eröffnen ? c = .Cells(3, 255).End(xlToRight).Column + 1 'Formatierung und Eintragungen für neues Produkt .Cells(2, c) = "Produkt " & c - 2 .Cells(3, c) = strPN c = c - 2 End If 'c = c + 2 .Cells(r0 + level - 1, c) = Val(strListe) ipos = InStr(strListe, "#") If ipos > 0 Then strListe = Mid(strListe, ipos) Else strListe = "" End If End If End If Wend End With End Sub Sub Einrichten() Dim c As Integer Dim RandNr As Variant On Error Resume Next Set wsPT = Worksheets("Produkttabelle") If wsPT Is Nothing Then Set wsPT = Worksheets.Add(Before:=Worksheets(1)) wsPT.Name = "ProduktTabelle" RandNr = Array(xlEdgeLeft, xlEdgeTop, xlEdgebottum, xlEdgeRight) 'alternativ c=7, 8, 9, 10 ProduktName = Array("", "AA", "AB", "ADU", "AR", "DD", "FG", "ZPN", "ZQ") With wsPT .Range("A1:A3").MergeCells = True .Range("A4:A8").MergeCells = True .Range("B1:B3").MergeCells = True .Range("C1:J1").MergeCells = True .Cells(3, 1) = "Auftrag" .Cells(3, 2) = "Level" For c = 1 To 8 .Cells(2, c + 2) = "Produkt " & c .Cells(3, c + 2) = ProduktName(c) Next c .Cells(1, 3) = "Produkte" For c = 1 To 5 .Cells(3 + c, 2) = "LE" & c Next c With Range("A1:J8") For c = 0 To 3 'alternativ in 2003: for c=7 to 10 With .Borders(c) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = 1 End With Next c End With With .Range("A1:J3,A4:B8") .Interior.ColorIndex = 36 .HorizontalAlignment = xlCenter End With r0 = 4 End With Else With wsPT r0 = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 c = .Cells(3, 255).End(xlToLeft).Column + 1 .Range(Cells(r0 - 5, 1), Cells(r0 - 1, c)).Copy Destination:=.Cells(r0, 1) .Range(Cells(r0, 3), Cells(r0 + 4, c)).ClearContents End With End If End Sub
Dieser Code geht davon aus, dass es maximal fünf Stufen gibt. Die Produktnamen sind nach Deiner Vorgabetabelle angelegt, können aber auch erweitert werden, was allerdings noch nict getestet wurde.
Auch sind nicht alle denkbaren Syntaxfehler innerhalb des Vorgabestrings abgefangen. Hier müßte eine entsprechnde Falluntersuchung noch erfolgen (enthält String ein oder mehrere Zeichen, das bzw. die nicht in #ABC...XY012..9 auftaucht?)
Sofern Erklärungsbedarf zum Programmcode besteht, kann ich darauf ab morgen nicht mehr zeitnah eingehen.
Gutes Gelingen!
Uwe

... Else With wsPT r0 = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 c = .Cells(3, 255).End(xlToLeft).Column + 1 .Range(.Cells(r0 - 5, 1), .Cells(r0 - 1, c)).Copy Destination:=.Cells(r0, 1) .Range(.Cells(r0, 3), .Cells(r0 + 4, c)).ClearContents End With End If End Sub

Beliebteste Forumthreads (12 Monate)

Zelleninhalt auf mehrere Zellen splitten

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zelleninhalt auf mehrere Zellen splitten

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread