|
Zelleninhalt auf mehrere Zeilen und Spalten verteilen
|
| Autor |
Nachricht |
Hannes878
Gast
Verfasst am:
28. Apr 2014, 17:24
Rufname:
|
|
| Version: Office 2007 |
|
Hallo Liebe Gemeinde,
anbei ein Beispiel, wie ich eine bestimmte Liste sortieren will.
Es geht darum, dass in einer Zelle doppelt hintereinander aufgeführt verschiedene Informationen stehen (Der Export ist der Datenbank ist nicht ganz sauber). Getrennt werden die einzelnen Informationen durch 7 "" (7 Leerzeichen). Die Werte an der jeweiligen Position in den unterschiedlichen Zellen gehören zusammen, sprich die dritte Information in Zelle A1 gehört zur dritten Information in Zelle B1. Ich müsste quasi neue Zeilen einfügen (siehe unten).
Nun sieht das ganze in der Quelldatei so aus:
Es soll aber in jeder Zelle nur ein Wert stehen, sprich jede Information muss in eine neue Zeile eingefügt werden.
Ziel:
Bitte um Hilfe!!! Gibt auch n Kaffee 
PS: Ganz toll wäre es, wenn das ganze wenig rechenintensiv wäre, da insgesamt 10000Zeilen:-/
Viele Grüße
|
|
slowboarder
Im Profil kannst Du frei den Rang ändern
Verfasst am:
28. Apr 2014, 18:02
Rufname:
|
|
| Version: Office 2007 |
|
Hi
probier mal folgendes:
| Code: | Sub test()
Dim arr1
Dim arr2
Dim Anz As Long
Dim z1 As Long
Dim z2 As Long
Dim i As Long
Dim sp As Long
Dim TeilTexte() As String
'--- Ausgangsdaten Einlesen, Anzahl der Ergebniszeilen ermitteln
With ActiveSheet.UsedRange
arr1 = .Value
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "=(LEN(RC[-1])-LEN(SUBSTITUTE(RC[-1],"" "", """")))/7+1"
Anz = WorksheetFunction.Sum(.Cells)
.ClearContents
End With
End With
ReDim arr2(1 To Anz, 1 To UBound(arr1, 2))
'--- Überschrift übernehmen
For sp = 1 To UBound(arr1, 2)
arr2(1, sp) = arr1(1, sp)
Next
'--- Daten ermitteln
z2 = 2
For z1 = 2 To UBound(arr1, 1)
For sp = 1 To UBound(arr1, 2)
TeilTexte = Split(arr1(z1, sp), String(7, " "))
For i = 0 To UBound(TeilTexte)
arr2(z2 + i, sp) = TeilTexte(i)
Next
Next
z2 = z2 + UBound(TeilTexte) + 1
Next
'--- Ergebnis ausgeben
Cells(1, 1).Resize(UBound(arr2, 1), UBound(arr2, 2)).Value = arr2
End Sub |
|
|
hannes878
Gast
Verfasst am:
28. Apr 2014, 18:24
Rufname:
|
|
| Version: Office 2007 |
|
Hallo,
Danke für die rasche Antwort!
Probier es morgen im Büro gleich aus und geb Feedback!
Da freut mich sich ja richtig auf den nächsten Arbeitstag,
Danke nochmal
Viele Grüße,
Hannes
|
|
slowboarder
Im Profil kannst Du frei den Rang ändern
Verfasst am:
28. Apr 2014, 19:17
Rufname:
|
|
| Version: Office 2007 |
|
Hi
nochmal optimiert.
ich hatte übersehen, dass in Spalte B nur ein Wert steht, der für alle übernommen werden soll:
| Code: | Sub test()
Dim arr1
Dim arr2
Dim Anz As Long
Dim z1 As Long
Dim z2 As Long
Dim i As Long
Dim sp As Long
Dim TeilTexte() As String
'--- Ausgangsdaten Einlesen, Anzahl der Ergebniszeilen ermitteln
With ActiveSheet.UsedRange
arr1 = .Value
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "=(LEN(RC[-1])-LEN(SUBSTITUTE(RC[-1],"" "", """")))/7+1"
Anz = WorksheetFunction.Sum(.Cells)
.ClearContents
End With
End With
ReDim arr2(1 To Anz, 1 To UBound(arr1, 2))
'--- Überschrift übernehmen
For sp = 1 To UBound(arr1, 2)
arr2(1, sp) = arr1(1, sp)
Next
'--- Daten ermitteln
z2 = 2
For z1 = 2 To UBound(arr1, 1)
Application.StatusBar = "in Bearbeitung: " & Format(z1 / UBound(arr1, 1), "0%")
Anz = UBound(Split(arr1(z1, 1), String(7, " ")))
For sp = 1 To UBound(arr1, 2)
TeilTexte = Split(arr1(z1, sp), String(7, " "))
If UBound(TeilTexte) = 0 Then
For i = 0 To Anz
arr2(z2 + i, sp) = TeilTexte(0)
Next
Else
For i = 0 To UBound(TeilTexte)
arr2(z2 + i, sp) = TeilTexte(i)
Next
End If
Next
z2 = z2 + UBound(TeilTexte) + 1
Next
'--- Ergebnis ausgeben
Cells(1, 1).Resize(UBound(arr2, 1), UBound(arr2, 2)).Value = arr2
Application.StatusBar = False
End Sub |
Gruß Daniel
|
|
Phelan XLPH
Fortgeschritten
Verfasst am:
28. Apr 2014, 20:19
Rufname: Phelan
|
|
| Version: Office 2007 |
|
Hallo,
eine ähnliche/weitere Variante:
| Code: | Sub xlph()
Dim avarResult As Variant
Dim avarData As Variant
Dim lngIndexD As Long
Dim lngIndexI As Long
Dim lngIndexR As Long
Dim lngCountR As Long
Dim avarID As Variant
Dim avarName As Variant
Dim avarData1 As Variant
Dim avarData2 As Variant
Dim avarData3 As Variant
avarData = Tabelle1.Range("A1").CurrentRegion.Value
For lngIndexD = LBound(avarData) + 1 To UBound(avarData)
lngCountR = lngCountR + UBound(Split(WorksheetFunction.Trim(avarData(lngIndexD, 1)), " ")) + 1
Next
ReDim avarResult(1 To lngCountR, 1 To 5)
With WorksheetFunction
For lngIndexD = LBound(avarData) + 1 To UBound(avarData)
avarID = Split(.Trim(avarData(lngIndexD, 1)), " ")
avarName = Split(.Trim(avarData(lngIndexD, 2)), " ")
avarData1 = Split(.Trim(avarData(lngIndexD, 3)), " ")
avarData2 = Split(.Trim(avarData(lngIndexD, 4)), " ")
avarData3 = Split(.Trim(avarData(lngIndexD, 5)), " ")
For lngIndexI = LBound(avarID) To UBound(avarID)
lngIndexR = lngIndexR + 1
avarResult(lngIndexR, 1) = avarID(lngIndexI)
avarResult(lngIndexR, 2) = avarName(LBound(avarID))
avarResult(lngIndexR, 3) = avarData1(lngIndexI)
avarResult(lngIndexR, 4) = avarData2(lngIndexI)
avarResult(lngIndexR, 5) = avarData3(lngIndexI)
Next
Next
End With
Tabelle1.Range("A2").Resize(UBound(avarResult), UBound(avarResult, 2)).Value = avarResult
End Sub |
_________________
Was vorstellbar ist, ist auch machbar. - Albert Einstein
|
|
Hannes878
Gast
Verfasst am:
29. Apr 2014, 11:11
Rufname:
|
|
| Version: Office 2007 |
|
Hallo,
erstmal vielen Dank. Es funktionieren beide Algorithmen sehr gut. Allerdings ist die vorherrschende Datenmenge viel zu groß, was jedes mal zu einem Runtime-Error führt.
Wie muss ich denn den Algorithmus abändern, dass die oben beschriebene Logik nur für die erste Spalte gilt?
Sprich die Werte der ersten Spalte sollen wie oben skizziert getrennt werden, und der Inhalt aller anderen Spalten 1:1 kopiert; sprich man hat bis auf die erste Spalte manchmal identische Zeilene
|
|
Hannes878
Gast
Verfasst am:
29. Apr 2014, 11:33
Rufname:
|
|
| Version: Office 2007 |
|
By the way,
in Spalte A können beliebig viele Identifier hintereinander (getrennt durch " " / 7 x Leerzeichen) stehen.
Ich kriegs nicht hinter, hab mir locker schon n Kilo haare ausgerissen ^^
lg
|
|
slowboarder
Im Profil kannst Du frei den Rang ändern
Verfasst am:
29. Apr 2014, 12:46
Rufname:
|
|
| Version: Office 2007 |
|
Hi
bei meinem 2. Code musst du bei dieser Datenkonstellation gar nichts anpassen, er setzt das automatisch richtig um.
von welcher Datenmenge redest du denn?
ein Tabellenblatt hat maximal 2^20 = c.a. 1,04 Mio Zeilen
wenn als Ergebnis mehr rauskommen, müsstest du die Ausgangsdaten auf mehrer Sheets verteilen, so dass pro Sheet nicht mehr als die genannte Zeilenmenge entsteht.
füge folgende Zeilen vor dem ReDim ein, damit wird überprüft, ob die Daten auf ein Blatt passen:
| Code: | If Anz > 20 ^ 2 Then
MsgBox "Datenmenge zu gross." & vbLf & _
"Zeilen soll: " & Format(Anz, "#,##0") & vbLf & _
"Zeilen ist : " & Format(2 ^ 20, "#,###0")
Exit Sub
End If |
Gruß Daniel
|
|
Gast
Verfasst am:
29. Apr 2014, 16:46
Rufname:
|
|
| Version: Office 2007 |
|
Das Problem ist, dass manche Datenfelder legitim leer sind, sprich z.B. Spalte "Data1" oder "Data2" sind leer. Diese Zeilen werden leider vollständig gelöscht... und ich finde nicht heraus warum.
Dein Makro ist ein Top Startpunkt, keine Frage. danke nochmals
|
|
slowboarder
Im Profil kannst Du frei den Rang ändern
Verfasst am:
29. Apr 2014, 17:04
Rufname:
|
|
| Version: Office 2007 |
|
Es wäre hilfreich, wenn du
a) ein Beispieldatei hochladen würdest
diese Beispieldatei sollte die Daten so realistisch wie möglich darastellen (unter beachtung des Datenschutzes)
wenige Zeilen reichen, aber es sollte jede mögliche Datenkonstellation mindestens einmal vorkommen
die Variante mit leeren Feldern kam jetzt in deinen Bildern nicht vor, also wird sie vom Programmierer idR auch nicht berücksichtigt.
b) genau beschreiben, wie gross die Datenmenge tatsächlich ist (Anzahl Spalten, Anzahl Zeilen der Ausgangsdatei, Anzahl Zeilen der Zieldatei).
Gruß Daniel
|
|
Hannes878
Gast
Verfasst am:
29. Apr 2014, 17:15
Rufname:
|
|
| Version: Office 2007 |
|
Hallo Daniel,
Wegen den leeren Feldern, Sry. War keine Absicht:)
Wie stell ich das an, dass leere Felder nicht zu einem löschen der Zeile führt?
Datei folgt morgen, glaub ich hab noch einen Fehler gefunden, und zwar enden manche Zellen mit einen Punkt ( das war vorab nicht erkennbar, da erst ab Zeile 63873), sprich " ." das Problem hab ich aber im Griff...
Kannst du mir nochmal mit der Leerstellen - Toleranz helfen?
Viele Grüße
|
|
slowboarder
Im Profil kannst Du frei den Rang ändern
Verfasst am:
29. Apr 2014, 17:23
Rufname:
|
|
| Version: Office 2007 |
|
können schon, aberr morgen keine Zeit und jedes mal deine Datei neu aufzubauen hab ich auch keinen Bock.
Gruß Daniel
|
|
Hannes878
Gast
Verfasst am:
29. Apr 2014, 17:29
Rufname:
|
|
| Version: Office 2007 |
|
Hallo Daniel,
Klar - versteh ich...ich lad dir morgen einfach einmal eine Datei hoch, und probier es nebenbei parallel selbst.
Freu mich, falls du mir bei Gelegenheit doch noch mal unter die Arme greifst.
Viele Grüße
|
|
slowboarder
Im Profil kannst Du frei den Rang ändern
Verfasst am:
29. Apr 2014, 17:33
Rufname:
|
|
| Version: Office 2007 |
|
Hi
ändere mal die markierten Zeilen, dann sollte es funktionieren:
| Code: | Sub test()
Dim arr1
Dim arr2
Dim Anz As Long
Dim z1 As Long
Dim z2 As Long
Dim i As Long
Dim sp As Long
Dim TeilTexte() As String
'--- Ausgangsdaten Einlesen, Anzahl der Ergebniszeilen ermitteln
With ActiveSheet.UsedRange
arr1 = .Value
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "=(LEN(RC1)-LEN(SUBSTITUTE(RC1,"" "", """")))/7+1" '<------------
Anz = WorksheetFunction.Sum(.Cells)
.ClearContents
End With
End With
ReDim arr2(1 To Anz, 1 To UBound(arr1, 2))
'--- Überschrift übernehmen
For sp = 1 To UBound(arr1, 2)
arr2(1, sp) = arr1(1, sp)
Next
'--- Daten ermitteln
z2 = 2
For z1 = 2 To UBound(arr1, 1)
Application.StatusBar = "in Bearbeitung: " & Format(z1 / UBound(arr1, 1), "0%")
Anz = UBound(Split(arr1(z1, 1), String(7, " ")))
For sp = 1 To UBound(arr1, 2)
TeilTexte = Split(arr1(z1, sp), String(7, " "))
If UBound(TeilTexte) = 0 Then
For i = 0 To Anz
arr2(z2 + i, sp) = TeilTexte(0)
Next
Else
For i = 0 To UBound(TeilTexte)
arr2(z2 + i, sp) = TeilTexte(i)
Next
End If
Next
z2 = z2 + Anz + 1 '<------------
Next
'--- Ergebnis ausgeben
Cells(1, 1).Resize(UBound(arr2, 1), UBound(arr2, 2)).Value = arr2
Application.StatusBar = False
End Sub |
Gruß Daniel
|
|
Hannes878
Gast
Verfasst am:
30. Apr 2014, 20:00
Rufname:
|
|
| Version: Office 2007 |
|
Hallo Daniel,
die Testdatei kann ich mir sparen, funktioniert tadellos.
Vielen Dank für deine Unterstützung mein "excelgrüner" Engel.
Grüße
|
|
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen
|
|
|
|
| Verwandte Themen |
| Forum / Themen |
Antworten |
Autor |
Aufrufe |
Letzter Beitrag |
 |
Excel Formeln: Prüfung, ob Zelleninhalt numerisch ist?! |
1 |
JimmyT |
2630 |
22. Apr 2005, 11:55
Günni  |
|
Excel Formeln: Muß Daten kopieren mit Bezug auf mehrer Zeilen |
3 |
Anke |
1487 |
07. Apr 2005, 10:54
Anke |
|
Excel Formeln: Zeilen mit Eintrag zählen |
2 |
Martymak |
1192 |
06. Apr 2005, 11:09
Martymak |
|
Excel Formeln: spalten multipizieren |
3 |
traum1954 |
1385 |
06. Apr 2005, 08:52
julilia |
|
Excel Formeln: Teilergebnis bzw. Summe mit ausgeblendeten Spalten |
6 |
Hauns123 |
9997 |
08. März 2005, 12:36
rainberg |
|
Excel Formeln: Spalten Sortieren |
23 |
Fireball8 |
3108 |
07. Jan 2005, 18:40
fridgenep |
|
Excel Formeln: Zeilen mit doppelten Werten löschen |
6 |
Sebowsky |
1208 |
06. Jan 2005, 22:26
Sebowsky |
|
Excel Formeln: Erster Wert aus mehreren Spalten |
4 |
Gast |
1922 |
03. Dez 2004, 10:52
Arnim |
|
Excel Formeln: Vor- und Nachname in 1 Spalte in 2 Spalten aufteilen |
2 |
Gast |
2920 |
26. Nov 2004, 11:48
Gast |
|
Excel Formeln: ZÄHLENWENN bei 2 Suchkriterien in wechselnden Spalten |
10 |
Rebecca Nau |
1909 |
12. Nov 2004, 11:26
Arnim |
|
Excel Formeln: Wenn-Bedingung mit mehreren Spalten und Zeile |
6 |
Lusie |
2819 |
02. Nov 2004, 15:57
Lusie |
|
Excel Formeln: Druckbereich:nur einzelne Spalten als Druckbereich markieren |
3 |
mufty001 |
1912 |
21. Okt 2004, 09:24
mufty001 |
| |
|
