Tabelle mit Hilfe VBA sortieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Björn,
ums Sortieren geht es wohl weniger. Ich vermute als Ziel, dass die Daten wieder spaltengerecht in der Tabelle stehen.
Die Beispieltabelle in 88666.xlsx zeigt leider wenig Unterschied zwischen Überschriften und Daten.
Zeile 1 (Überschriften?) ist z. B. identisch mit Zeile 12.
Wie soll denn das Ergebnis aussehen? Wo soll es gespeichert werden?
Hier eine Möglichkeit:

	N	O	P	Q	R	S
1	Firma	Adresse 1	Straße	PLZ	Ort	Website
2	Wert_Firma	Wert_Adresse		Wert_PLZ	Wert_Ort	Wert_Website
3	Wert_Firma		Wert_Straße	Wert_PLZ	Wert_Ort	Wert_Website
4	Wert_Firma			Wert_PLZ	Wert_Ort	Wert_Website
5	Wert_Firma	Wert_Adresse
6	Wert_Firma	Wert_Adresse
7	Wert_Firma				Wert_Ort	Wert_Website
8	Wert_Firma		Wert_Straße	Wert_PLZ	Wert_Ort	Wert_Website
9	Wert_Firma			Wert_PLZ	Wert_Ort	Wert_Website
10	Wert_Firma	Wert_Adresse
11	Wert_Firma				Wert_Ort	Wert_Website
12	Wert_Firma	Wert_Adresse	Wert_Straße	Wert_PLZ	Wert_Ort	Wert_Website
13	Wert_Firma	Wert_Adresse		Wert_PLZ	Wert_Ort	Wert_Website
14	Wert_Firma				Wert_Ort	Wert_Website
15	Wert_Firma	Wert_Adresse
16	Wert_Firma	Wert_Adresse
17	Wert_Firma				Wert_Ort	Wert_Website
18	Wert_Firma		Wert_Straße	Wert_PLZ	Wert_Ort	Wert_Website
19	Wert_Firma			Wert_PLZ	Wert_Ort	Wert_Website
20	Wert_Firma	Wert_Adresse
21	Wert_Firma				Wert_Ort	Wert_Website
22	Wert_Firma	Wert_Adresse	Wert_Straße	Wert_PLZ	Wert_Ort	Wert_Website
23	Wert_Firma	Wert_Adresse		Wert_PLZ	Wert_Ort	Wert_Website
24	Wert_Firma				Wert_Ort	Wert_Website

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Dass man hier nicht so furchtbar viel erkennen kann, liegt an deinen Beispieldaten...
Es fehlen jedenfalls die Daten in den Quellzellen B1, D1, F1, H1, J1, L1. (In Zeile 1 sollten Überschriften stehen.)
Soll das Ergebnis so werden?
Erstellt habe ich das (erst mal ein gerade aktives Blatt) mit Option Explicit Sub ReStrukt() Dim lngZ As Long, lngS As Long, arQ, arE() Dim zz As Long, ss As Long, tt As Long lngZ = Cells(Rows.Count, 1).End(xlUp).Row lngS = Cells(1, Columns.Count).End(xlToLeft).Column arQ = Cells(1, 1).Resize(lngZ, lngS) ReDim arE(1 To lngZ, 1 To lngS / 2) For ss = 1 To UBound(arE, 2) arE(1, ss) = arQ(1, 2 * ss - 1) Next ss For zz = 2 To UBound(arQ) For ss = 1 To UBound(arQ, 2) For tt = 1 To UBound(arE, 2) If arE(1, tt) = arQ(zz, ss) Then arE(zz, tt) = arQ(zz, ss + 1) Exit For End If Next tt Next ss Next zz Cells(1, lngS + 2).Resize(lngZ, UBound(arE, 2)) = arE End Sub Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Hi Björn,
vor weiterer Hilfe wären m. E. noch ein paar Fragen zu klären.
Ich hatte geschrieben:
"Es fehlen jedenfalls die Daten in den Quellzellen B1, D1, F1, H1, J1, L1. (In Zeile 1 sollten Überschriften stehen.)"
1. Frage:
Ist das so in Ordnung, dass die Daten in B1 usw. einfach wegfallen?
2. Frage:
Eine Excelmappe enthält oft mehrere Tabellenblätter. Ist das bei deinen Mappen so?
Oder soll immer ein bestimmtes Blatt (Name?) der jeweiligen Mappe bearbeitet werden?
3. Frage:
Zumindest beim Testen würde mich sehr stören, dass die Ursprungsdaten überschrieben werden.
Damit ist kein Test einfach wiederholbar. Willst du das trotzdem so handhaben?
4. Frage: Du schreibst:
"Die Werte werden nach ausführen des Codes ab Spalte V eingefügt. Ich müsste eine Möglichkeit haben,
dass die Dateien nacheinander geöffnet werden, Spalte A-U gelöscht und abgespeichert wird."
Das verstehe ich nicht.
Wer oder was fügt welche Werte nach Ausführen des Codes ab Spalte V ein?
Wann sollen wodurch die Spalten A:U gelöscht werden?
5. ist keine Frage, sondern eine Bitte:
Lad doch bitte mal eine konkrete Beispielmappe hoch, in der Überschriften und Daten als solche erkennbar sind.
So ca. 5 Datensätze sollten ausreichen, die Daten kannst du ja anonymisieren.
Die Mappe sollte ein Blatt mit dem derzeitigen Aufbau und ein zweites Blatt mit dem gewünschten Ergebnis
enthalten.
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Option Explicit Sub SchleifeDateien() Dim strVz As String, strD As String Const cVrz As String = "c:\temp" ' hier Verzeichnis festlegen Const cTyp As String = "xlsx" ' hier Dateityp festlegen strVz = cVrz & IIf(Right(cVrz, 1) = "\", "", "\") strD = Dir(strVz & "*." & cTyp) Do While strD "" Workbooks.Open strVz & strD ' öffnet die nächste Mappe Sheets("Tabelle1").Select ReStrukt Workbooks(strD).Close True ' speichert und schließt die Mappe strD = Dir() Loop End Sub Sub ReStrukt() ' arbeitet auf dem gerade aktiven Tabellenblatt Dim lngZ As Long, lngS As Long, arQ, arE() Dim zz As Long, ss As Long, tt As Long lngZ = Cells(Rows.Count, 1).End(xlUp).Row lngS = Cells(1, Columns.Count).End(xlToLeft).Column arQ = Cells(1, 1).Resize(lngZ, lngS) ReDim arE(1 To lngZ, 1 To lngS / 2) For ss = 1 To UBound(arE, 2) arE(1, ss) = arQ(1, 2 * ss - 1) Next ss For zz = 2 To lngZ For ss = 1 To lngS If IsEmpty(arQ(zz, ss)) Then Exit For For tt = 1 To UBound(arE, 2) If arE(1, tt) = arQ(zz, ss) Then arE(zz, tt) = arQ(zz, ss + 1) Exit For End If Next tt Next ss Next zz Range(Cells(1, 1), Cells(1, lngS)).EntireColumn.Delete Cells(1, 1).Resize(lngZ, UBound(arE, 2)) = arE End Sub

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread