PDA

Vollständige Version anzeigen : Wenn zwei Zellen gleich dann Nachbarinhalte nebeneinander


AlexFDS
03.07.2014, 22:41
Hallo zusammen,

mein Name ist Alex und ich bin neu hier. Sagt mir bitte einfach, falls ich gegen die Forenetikette verstoße.

Zu meinem Problem:

Ich habe fünf Spalten. Wenn der Wert in Spalte A in einer Zeile identisch mit einer anderen ist, dann sollen die Inhalte aus Spalte B nebeneinander dargestellt werden. Also ZelleA23=5, Zelle A46=5, Zelle B23 = Bier, Zelle B46= Wein, dann soll auf einem neuen Blatt erscheinen A1=5,B1=Bier,C1=Wein. Leider weiß ich nie wie oft sich ein Wert in Spalte A wiederholt. Dies kann 3x sein, dies kann aber auch 15x sein. Dementsprechend ist die Anzahl der benötigten Zellen pro Wert unterschiedlich.

Ist mein Problem verständlich erklärt? Kann mir jemand helfen?
Das wäre großartig. Vielen vielen Dank!

Mc Santa
03.07.2014, 23:05
Hallo zusammen,

mein Name ist Alex und ich bin neu hier. Sagt mir bitte einfach, falls ich gegen die Forenetikette verstoße.

Zu meinem Problem:

Ich habe fünf Spalten. Wenn der Wert in Spalte A in einer Zeile identisch mit einer anderen ist, dann sollen die Inhalte aus Spalte B nebeneinander dargestellt werden. Also ZelleA23=5, Zelle A46=5, Zelle B23 = Bier, Zelle B46= Wein, dann soll auf einem neuen Blatt erscheinen A1=5,B1=Bier,C1=Wein. Leider weiß ich nie wie oft sich ein Wert in Spalte A wiederholt. Dies kann 3x sein, dies kann aber auch 15x sein. Dementsprechend ist die Anzahl der benötigten Zellen pro Wert unterschiedlich.

Ist mein Problem verständlich erklärt? Kann mir jemand helfen?
Das wäre großartig. Vielen vielen Dank!

Hallo,

Meintest du hier vielleicht zwei Spalten?

VG

Mc Santa
03.07.2014, 23:30
Hallo,

schau mal ob du mit diesem Makro etwas anfangen kannst, Beispieldatei im Anhang:
Option Explicit

Sub datenStrukturieren()

Application.ScreenUpdating = False

Dim wsSrc As Worksheet, wsTar As Worksheet
Dim lastRow As Long
Dim rng As Range, dest As Range

Set wsSrc = Worksheets("Quelle")
Set wsTar = Worksheets("Ziel")

lastRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

wsTar.Cells.Clear
For Each rng In wsSrc.Range(wsSrc.Cells(1, 1), wsSrc.Cells(Rows.Count, 1).End(xlUp))

Set dest = Nothing
Set dest = wsTar.Cells(1, 1).EntireColumn.Find(What:=rng.Value, After:=wsTar.Cells(1, 1), LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If dest Is Nothing Then
wsTar.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 2) = Array(rng, rng.Offset(, 1))
Else
dest.End(xlToRight).Offset(, 1) = rng.Offset(, 1)
End If

Next rng

Application.Goto wsTar.Cells(1, 1), True
Application.ScreenUpdating = True

End Sub

Fragen dazu gerne, freue mich über Feedback :)
VG

AlexFDS
04.07.2014, 11:30
Hi Santa,

habe das gerade probiert. Erst habe ich meine Originaldaten eingefügt. Da ging es nicht. Dann habe ich es mit Deiner Beispieltabelle versucht. Auch da kam die Fehlermeldung "Argument nicht gefunden". Schade. Ich dachte ich hätte dieses Problem gelöst.

Würdest Du es Dir nochmal anschauen?

Viele Grüße,

Alex

Mc Santa
04.07.2014, 11:37
Hallo,

zunächst: War denn meine Verbesserung richtig, oder habe ich das Falsch interpretiert?

Und: Wo tritt der Fehler auf, in welcher Zeile? Welche Excel-Version benutzt du?

Bei mir geht es in Excel 2003, 2007 und 2010
VG

AlexFDS
04.07.2014, 11:52
Hi Santa,

im Endeffekt war meine Beschreibung schon richtig. Ich habe tatsächlich fünf Spalten, von diesen sind aber nur zwei Spalten relevant. Also habe diese beiden Spalten in deine Vorlage kopiert, was nicht funktioniert hat. Der Fehler tritt in keiner Zeile auf. Es heißt sofort wenn ich auf deinen Button klicke "Argument nicht gefunden".

Ich nutze (jetzt schlag mich nicht) Excel 2011 für Mac

Mc Santa
04.07.2014, 11:55
Hallo,

OK, dann müssen wir mal schauen, woran es liegt...

Wenn die Fehlermeldung aufkommt, wird dann eine Zeile gelb markiert? Wenn ja, welche Zeile?
Und wie genau lautet die Fehlermeldung?

VG

AlexFDS
04.07.2014, 12:03
Hallo,

es kommt beim klick auf den Button kein gelb markiertes Feld. Gehe ich im Makro Menü jedoch auf "Einzelschritte verfolgen, so ist gleich die erste Zeile "Sub datenStrukturieren" gelb unterlegt.

Sub datenStrukturieren()

Application.ScreenUpdating = False

Dim wsSrc As Worksheet, wsTar As Worksheet
Dim lastRow As Long
Dim rng As Range, dest As Range

Set wsSrc = Worksheets("Quelle")
Set wsTar = Worksheets("Ziel")

lastRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

wsTar.Cells.Clear
For Each rng In wsSrc.Range(wsSrc.Cells(1, 1), wsSrc.Cells(Rows.Count, 1).End(xlUp))

Set dest = Nothing
Set dest = wsTar.Cells(1, 1).EntireColumn.Find(What:=rng.Value, After:=wsTar.Cells(1, 1), LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If dest Is Nothing Then
wsTar.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 2) = Array(rng, rng.Offset(, 1))
Else
dest.End(xlToRight).Offset(, 1) = rng.Offset(, 1)
End If

Next rng

VG und Danke

Mc Santa
04.07.2014, 12:46
Hallo,

ok das ist etwas merkwürdig.

Wenn du die Variante "Einzelschritt" gehst, dann musst du das auch ganz oft machen (Für jeden Einzelschritt, im Makro ist das immer eine Zeile). Bei mir klicke ich dazu oft hintereinander auf F8, ob das bei dir auch so geht, weiß ich nicht.

Wichtig ist für mich, wann das Makro bei dir abstürzt, denn bei mir geht es, wie gesagt.

VG

AlexFDS
04.07.2014, 13:36
Ich klicke nach dem Öffnen der Datei gleich auf den Button. Ist das evtl. der Fehler?

Muss ich vielleicht erst einen Wert definieren nach dem ich Suche?

Die Fehlermeldung ist "Das benannte Argument wurde nicht gefunden" oder ist es so programmiert, das sich alle Werte aus Spalte 1 automatisch in dem neuen Datenblatt wiederfinden?


Danke für Deine Hilfe.

Mc Santa
04.07.2014, 13:48
Hallo,

Es werden alle Zeilen berücksichtigt, die Ausgabe sieht bei mir so aus:
<br/><b><em>Ziel</em></b><table border="1" cellspacing="0" cellpadding="0" style="border-color:#000000; border-width: 1px; font-size:11pt; background-color:#ffffff; padding-left:2pt; padding-right:2pt; "><colgroup><col style="font-weight:bold; width:40px;" /><col style="width:97px;" /><col style="width:97px;" /><col style="width:97px;" /><col style="width:97px;" /><col style="width:97px;" /></colgroup><tr style="background-color:#99CCFF; text-align:center; font-weight:bold; "><td>&nbsp;</td><td>A</td><td>B</td><td>C</td><td>D</td><td>E</td></tr><tr><td style="background-color:#99CCFF; text-align:center; font-weight:bold; ">1</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td></tr><tr><td style="background-color:#99CCFF; text-align:center; font-weight:bold; ">2</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">1</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Bier</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Wein</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Stuhl</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Brunnen</td></tr><tr><td style="background-color:#99CCFF; text-align:center; font-weight:bold; ">3</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">2</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Apfel</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Baum</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Hamster</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td></tr><tr><td style="background-color:#99CCFF; text-align:center; font-weight:bold; ">4</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">3</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Orange</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Tier</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td></tr><tr><td style="background-color:#99CCFF; text-align:center; font-weight:bold; ">5</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">4</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Erdbeere</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Ast</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td></tr><tr><td style="background-color:#99CCFF; text-align:center; font-weight:bold; ">6</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">5</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Tisch</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Garage</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">PC</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Haus</td></tr><tr><td style="background-color:#99CCFF; text-align:center; font-weight:bold; ">7</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">6</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Vogel</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Tomate</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td></tr><tr><td style="background-color:#99CCFF; text-align:center; font-weight:bold; ">8</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">8</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:left; ">Fisch</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td><td style="border-color:#000000; color:#000000; border-color:#000000; background-color:#FFFFFF ;; text-align:right; ">&nbsp;</td></tr></table><table cellspacing="0" cellpadding="0"><tr style="text-align:left; font-weight:bold; " class="style21"><td style="text-align:left; font-size: xx-small" ><a href="http://excel-inn.de/dateien/vba_beispiele/tabellenanzeige_in_html_addin.zip" >Excel-Inn.de</a></td></tr> <tr style="text-align:left; font-weight:bold; " class="style21"><td style="text-align:left; font-size: xx-small" ><a href='http://Hajo-Excel.de/tools.htm' >Hajo-Excel.de</a></td></tr><tr style="text-align:left; font-weight:bold;" ><td style="text-align:left; font-size: xx-small" >XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007</td></tr><tr style="text-align:left; font-weight:bold; " ><td style="text-align:left; font-size: xx-small" > Add-In-Version 18.01 einschl. 64 Bit</td></tr></table><br/>


Leider weiß ich immer noch nicht, wo genau der Fehler auftritt, hast du versucht mit Einzelschritten durchzugehen? (nicht nur einmal Klicken, sondern so lange, bis das Makro fertig ist oder einen Fehler gibt)

Oder probiere mal diesen Code:
Option Explicit

Sub datenStrukturieren()

Application.ScreenUpdating = False

Dim wsSrc As Worksheet, wsTar As Worksheet
Dim lastRow As Long
Dim rng As Range, dest As Range

Set wsSrc = Worksheets("Quelle")
Set wsTar = Worksheets("Ziel")

lastRow = wsSrc.Cells(Rows.Count, 1).End(-4162).Row

wsTar.Cells.Clear
For Each rng In wsSrc.Range(wsSrc.Cells(1, 1), wsSrc.Cells(Rows.Count, 1).End(-4162))

Set dest = Nothing
Set dest = wsTar.Cells(1, 1).EntireColumn.Find(What:=rng.Value, After:=wsTar.Cells(1, 1), LookIn:=-4163, LookAt _
:=1, SearchOrder:=2, SearchDirection:=1, MatchCase:= _
False, SearchFormat:=False)
If dest Is Nothing Then
wsTar.Cells(Rows.Count, 1).End(-4162).Offset(1).Resize(, 2) = Array(rng, rng.Offset(, 1))
Else
dest.End(-4161).Offset(, 1) = rng.Offset(, 1)
End If

Next rng

Application.Goto wsTar.Cells(1, 1), True
Application.ScreenUpdating = True

End Sub

VG

AlexFDS
04.07.2014, 14:03
Da kommt jetzt "Laufzeitfehler 448" Das benannte Argument wurde nicht gefunden.

AlexFDS
04.07.2014, 14:05
und der Fehler ist in dieser Zeile:

Set dest = wsTar.Cells(1, 1).EntireColumn.Find(What:=rng.Value, After:=wsTar.Cells(1, 1), LookIn:=-4163, LookAt _
:=1, SearchOrder:=2, SearchDirection:=1, MatchCase:= _
False, SearchFormat:=False)

AlexFDS
05.07.2014, 15:04
Mist,

die Lust verloren, Santa?

Kann mir sonst vielleicht jemand helfen?

Mc Santa
05.07.2014, 20:24
Ich versuche Montag noch einmal zwei Varianten. Falls es gar nicht geht, baue ich eine Schleife zum suchen, kann dann vielleicht etwas dauern, bis das Makro fertig ist.

Um wie viele Zeilen geht es, die so sortiert werden sollen?

AlexFDS
06.07.2014, 07:01
Um 980.000...

aloys78
06.07.2014, 17:27
Hallo Alex,
Um wie viele Zeilen geht es, die so sortiert werden sollen?
Um 980.000...
Bei dieser Größenordnung schlage ich eine Array-basierte Lösung vor.
Nachstehend mein Vorschlag (Code in einen Modul einfügen):
Option Explicit

Sub datenStrukturieren()
Dim ws_Q As Worksheet 'Quell-Tabelle
Dim ws_Z As Worksheet 'Ziel-Tabelle
Dim LoL As Long 'Nr letzte Zeile mit Inhalt
Dim q As Long 'Zeilen# Quell-Tabelle bzw -Array
Dim z As Long 'Index ziel-Array
Dim s As Long 'Index 2 für Ziel-Array
Dim arr_Q() 'Array Quell-Daten
Dim arr_Z() 'Array Ziel-Daten
Dim a As Long 'Index arr_Q
Dim na As Long 'Anzahl Entries in arr_Q
Dim nz As Long 'Anzahl Entries in arr_Z
Dim sZeit As Single

'Initialisieren
sZeit = Timer
Set ws_Q = Worksheets("Quelle")
Set ws_Z = Worksheets("Ziel")

'Lade Quall-Array
With ws_Q
LoL = .Cells(Rows.Count, "A").End(xlUp).Row
ReDim arr_Q(0 To LoL + 1, 1 To 2)
a = 0
For q = 2 To LoL
a = a + 1
arr_Q(a, 1) = .Range("A" & q)
arr_Q(a, 2) = .Range("B" & q)
Next q
End With
na = a 'Anzahl Entries in Quell-Tabelle

'Sortieren nach Key (aus Sp A) u
Call BubbleSort(arr_Q, na, 1, 1) 'Sp A - aufsteigend

'Erstelle Ziel-Array
ReDim arr_Z(0 To na + 1, 1 To 16)
z = 0
For q = 0 To na + 1
'ws_Z.Range("D1") = q
'ws_Z.Range("E1") = z
If q = 979 Then
q = q + 0
End If
If arr_Q(q + 1, 1) <> arr_Q(q, 1) Then 'Spalte A-Ausdruck + max 15 Spalte B-Ausdrücke
z = z + 1
s = 2
Else
s = s + 1
If s > UBound(arr_Z, 2) Then ReDim Preserve arr_Z(1 To na, 1 To s) 'mehr als 15 Süalte B-Ausdrücke
End If
arr_Z(z, 1) = arr_Q(q + 1, 1)
arr_Z(z, s) = arr_Q(q + 1, 2)
Next q
nz = z

With ws_Z
.Range(.Cells(1, 1), .Cells(nz + 1, UBound(arr_Z, 2))) = arr_Z
End With
MsgBox Timer - sZeit
End Sub


Function BubbleSort(arr, idx_Ubound As Long, SortIndex As Long, swA As Integer)
'***********************************************************
' Sortieren 2-dimensionales Array
'***********************************************************
' arr = zu sortierendes array
' idx_Ubound = Obergrenze des zu sortierenden Array-Teils
' SortIndex = Position Sortierfeld
' swA = Sortierreihenfolge (0 = absteigend, 1 = aufsteigend)

Dim blnNoSwaps As Boolean
Dim lngItem As Long
Dim vntTemp() As Variant
Dim lngCol As Long
ReDim vntTemp(1 To UBound(arr, 2))
Do
blnNoSwaps = True
For lngItem = LBound(arr) To idx_Ubound - 1
If (swA = 1 And arr(lngItem, SortIndex) > arr(lngItem + 1, SortIndex)) Or _
(swA = 0 And arr(lngItem, SortIndex) < arr(lngItem + 1, SortIndex)) Then
blnNoSwaps = False
For lngCol = 1 To UBound(arr, 2)
vntTemp(lngCol) = arr(lngItem, lngCol)
arr(lngItem, lngCol) = arr(lngItem + 1, lngCol)
arr(lngItem + 1, lngCol) = vntTemp(lngCol)
Next
End If
Next
Loop While Not blnNoSwaps
End Function

Gruß
Aloys

Mc Santa
06.07.2014, 22:48
Hallo,

da ich parallel auch an einer neuen Antwort gebastelt habe, hier auch mein neuer Vorschlag:
Option Explicit

Sub sortData()
Dim wsSrc As Worksheet, wsTar As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim col As Collection

Set col = New Collection
Set wsSrc = ThisWorkbook.Worksheets("Quelldaten")
Set wsTar = ThisWorkbook.Worksheets("Ausgabeblatt")

lastRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

wsTar.Cells.ClearContents
For Each rng In wsSrc.Range(Cells(1, 1), Cells(lastRow, 1))

On Error Resume Next
col.Add wsTar.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row, rng.Value
If Err Then
Err.Clear
wsTar.Cells(col.Item(rng.Value), 1).End(xlToRight).Offset(, 1) = rng.Offset(, 1).Value
Else
wsTar.Cells(col.Item(rng.Value), 1).Resize(, 2) = Array(rng.Value, rng.Offset(, 1).Value)
End If
On Error GoTo 0
Application.StatusBar = "Das Makro arbeitet... Aktueller Stand: " & Format(rng.Row / lastRow, "0.00%")
Next rng
Application.StatusBar = False
End Sub



VG

AlexFDS
07.07.2014, 09:54
Ich bin überwältigt. Hätte niemals gedacht, dass mir hier so geholfen wird. Vielen vielen Dank!

Nun ein kurzer Zwischenstand:

Alois, Deine Datei hat bei mir bis auf einen kleinen Fehler (die erste Zeile wird nicht erfasst) tadellos bei einer Testdatenmenge funktioniert. Bei den 980.000 Spalten hat der Rechner nach 8 Stunden noch nichts ausgespuckt, was aber wohl eher an meinem MacBookPro liegt.

Santa, Deine Datei rechnet er seit 20 Minuten. Ich bin gespannt. Drückt mir die Daumen!

Mc Santa
07.07.2014, 10:01
Hallo,

Ok, danke schon einmal für dein Feedback, kannst ja dann Bescheid sagen, obs geklappt hat :)

Brauchst du dieses Makro einmalig oder häufiger? Wenn du das oft ausführen musst, würde ich noch einmal versuchen eine schnellere Variante programmieren, in der Excel nicht so viele Zellzugriffe benötigt.

VG

aloys78
07.07.2014, 10:38
Hallo Alex,
Alois, Deine Datei hat bei mir bis auf einen kleinen Fehler (die erste Zeile wird nicht erfasst) tadellos bei einer Testdatenmenge funktioniert.
Deine Daten beginnen dann in Zeile 1 statt 2; das wäre leicht zu korrigieren.
Bei den 980.000 Spalten hat der Rechner nach 8 Stunden noch nichts ausgespuckt, was aber wohl eher an meinem MacBookPro liegt.
Du meinst sicherlich Zeilen.
Also - bei meinem Win 7 Rechner, der sicherlich nicht der schnellste ist, waren es bei 980.000 Zeilen (Sp A und B) 32 Sekunden.

Gruß
Aloys

AlexFDS
07.07.2014, 14:44
Also, nochmal ich. Langsam ist es mir peinlich...

Die Berechnung von Santas Code hat ca. 4 Stunden gedauert und am Ende ist leider nur ein leeres Tabellenblatt erschienen. Mist, ich dachte das wäre die Lösung.

Aloys, das ist aber komisch, dass das bei mir so lange dauert.

Hm, was schlagt ihr vor?

Mc Santa
07.07.2014, 14:49
Hallo,

ich weiß leider nicht wieso es bei den vielen Daten nicht geht, obwohl es im Kleinen funktioniert.
Kannst du deine Datei zur Verfügung stellen, damit wir den Code selbst an den Daten testen können?

VG

aloys78
07.07.2014, 15:20
Hallo Alex,

da kann ich dem Kollegen Mc Santa nur zustimmen: wir brauchen deine Daten.

Denn ich hatte mir mit ein paar Zeilen VBA-Code eine Datei mit über 980.000 Zeilen nach deinen Regeln erstellt und dann damit getestet.

Gruß
Aloys

AlexFDS
07.07.2014, 21:31
Hallo zusammen,

leider ist die Datei 170mb groß und ich müsste ehrlicherweise auch erst meinen Prof fragen, ob ich die Daten rausgeben darf (sorry, komme mir richtig komisch vor). Ich weiß jetzt aber auch woran es liegt. Bei mir sind in den Zellen ausschließlich Zahlen, bei euch sind es Worte und Buchstaben. Ersetze ich meine Zahlen durch Buchstaben geht es. Allerdings geht es nicht, wenn ich die Zellen als Text formatiere.

Hoffe ihr seid nicht sauer. Kann ich irgendwie meine Dankbarkeit zeigen?

Mc Santa
07.07.2014, 21:44
Hallo,

Kannst du vielleicht mal ca 50 Zeilen hier hochladen? Vielleicht kannst du die Daten so verändern, dass man nicht mehr erkennt, was es ist. Aber vorsicht, dass die ART der Daten sich nicht verändert ;)

Eigentlich sollte es kein Problem sein, dass es bei dir Zahlen sind, aber der Teufel steckt ja bekanntlich im Detail.
Ich hoffe wir kommen noch zu einer Lösung :)

VG
Mc Santa

Wegen bedanken: Du kannst gute oder hilfreiche Beiträge unten links bewerten (drei kleine Symbole). Ich freue mich da immer!

AlexFDS
08.07.2014, 07:46
Vielen Dank,

hier mal ein Beispiel.

aloys78
08.07.2014, 11:04
Hallo Alex,

anbei das Ergebnis mit meinem Lösungsvorschlag.
Ich gebe im Moment die Daten sortiert nach den Werten in Spalte A aus, da bisher hierzu noch keine Vorgabe bestand.

Gruß
Aloys

Mc Santa
08.07.2014, 11:13
Hallo,

anbei noch einmal mein angepasster Code, allerdings sollte die Variante von Aloys schneller sein. Mein Code dauert etwa 20min, unten in der Statusleiste läuft eine Prozent-Angabe mit.
Sub sortData()
Dim wsSrc As Worksheet, wsTar As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim col As Collection

Set col = New Collection
Set wsSrc = ThisWorkbook.Worksheets("Quelle")
Set wsTar = ThisWorkbook.Worksheets("Ziel")

lastRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row

wsTar.Cells.ClearContents
Application.ScreenUpdating = False
For Each rng In wsSrc.Range(wsSrc.Cells(1, 1), wsSrc.Cells(lastRow, 1))

On Error Resume Next
col.Add wsTar.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row, CStr(rng.Value)
If Err Then
Err.Clear
wsTar.Cells(col.Item(CStr(rng.Value)), 1).End(xlToRight).Offset(, 1) = rng.Offset(, 1).Value
Else
wsTar.Cells(col.Item(CStr(rng.Value)), 1).Resize(, 2) = Array(rng.Value, rng.Offset(, 1).Value)
End If
On Error GoTo 0
Application.StatusBar = "Das Makro arbeitet... Aktueller Stand: " & Format(rng.Row / lastRow, "0.00%")
Next rng
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

VG

aloys78
08.07.2014, 16:14
Hallo Alex,

und hier der Lösungsvorschlag für den Fall, dass die Reihenfolge der Begriffe in Spalte A in der Ergebnisdarstellung gleich sein soll.

Gruß
Aloys

AlexFDS
09.07.2014, 11:31
Hallo ihr beiden,

wie gesagt: Ich bin überwältigt wie toll mir hier geholfen wurde. Santas Version hat funktioniert, bei Aloys erster Version kam ein Laufzeitfehler. Ich probiere jetzt nochmal die neue Version.

Außer euch gut zu bewerten kann ich mich ja leider nicht erkenntlich zeigen. Und bei Excel werde ich euch sicherlich nie helfen können.

Vielen vielen Dank!

aloys78
10.07.2014, 05:58
Hallo Alex,
Santas Version hat funktioniert, bei Aloys erster Version kam ein Laufzeitfehler.
Außer euch gut zu bewerten kann ich mich ja leider nicht erkenntlich zeigen.
Doch - durch ein qualifiziertes Feedback, hier zum Beispiel
- bei welcher Version konkret ?
- welcher Fehler ist aufgetreten ?

Ich habe mit fast 1 Million Daten (die nach deinen Vorgaben aufgebaut waren) getestet, und bin davon überzeugt, dass ich dir eine hoch performante Lösung präsentieren konnte.
Sollte tatsächlich ein Fehler vorliegen, kann auch ich von einer konkreten Fehlerbeschreibung profitieren.

Gruß
Aloys