Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1692to1696
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabelle anpassen / Spalte entfernen

Tabelle anpassen / Spalte entfernen
22.05.2019 15:11:20
Steve
Moin,
ich komme bei einme Problem nicht weiter. Ich möchte eine sich ständig in Länge und Breite ändernde Tabelle automatisch umwandeln.
In einer Zeile finden sich in je einer Zelle zwei Namen. Da ich die Tabelle mit Pivot auswerten möchte, muss die Tabelle aber auf eine Namensspalte reduziert werden.
Ein Beispiel:
Das ist der Ursprung:
Person A / Person B / Wert 1
Das Ziel soll so aussehen:
Person A / Wert 1
Person B / Wert 1
So kann ich dann alle Personen in einer Pivot nach Namen auswerten.
Ich habe es schon geschafft das die neue Tabelle unabhängig von der Größe erstellt wird.
Bedeuetet, das alle Überschriften übernommen werden.
Was ich aber nicht schaffe, ist, das ausser Name und Datum die restlichen Werte übernommen werden weil ich es nicht hinbekomme das rechte Ende der Tabelle (also die Breite) zu ermitteln.
Kann mir hier jemand helfen?
Liebe Grüße
Steve

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabelle anpassen / Spalte entfernen
22.05.2019 15:13:13
Steve
Moin,
das hier habe ich bisher.
Sub Spalte()
'Die Anzeige auf dem Bildschirm wird eingefroren um ein "Flimmern" zu vermeiden, wenn Arbeitsblä _
tter durch das Makro gewechselt werden
Application.ScreenUpdating = False
'Vorhandene Pivot wird gelöscht
Sheets("Daten1").Select
Columns("A:ZZ").Select
Selection.Delete Shift:=xlToLeft
'Neue Pivot wird erstellt und "Daten" genannt
Range("A1:A2").Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$A$2"), , xlYes).Name = _
"Datum"
Columns("A:A").Select
Selection.NumberFormat = "dd/mm/yy;@"
Worksheets("Eingabe").Activate
'Sucht die letzte beschriebene Spalte in der ersten Zeile
'Hier muss die 256 ggf. angepasst werden, falls die Zieltabelle auf dem selben Tabellenblatt  _
erzeugt werden soll
letztespalte = Sheets("Eingabe").Cells(1, 256).End(xlToLeft).Column
'jede gefüllte Spalte wird durchgelaufen
For s = 1 To letztespalte
Eingabe = Cells(1, s).Value
'Wenn der Inhalt der geprüften Zelle nicht Fahrer oder Beifahrer ist, dann...
If Cells(1, s).Value  "Fahrer" And Cells(1, s).Value  "Beifahrer" Then
'...wird der Inhalt der Zelle in die Variable aufgenommen (.value steht immer für "Inhalt der  _
Zelle")
'Ansonsten wird die Prozedur übersprungen und es wird zum "End if" (siehe Ende des Makros)  _
gesprungen
variable = Cells(1, s).Value
'Tabellenblatt mit der Zieldatei wird geöffnet
Worksheets("Daten1").Activate
'In die erste Zelle wird "Datum" geschrieben
Cells(1, 1).Value = "Datum"
'Tabellenblatt mit der Zieldatei wird geöffnet
Worksheets("Daten1").Activate
'In die erste Zelle wird "Datum" geschrieben
Cells(1, 2).Value = "Team"
'die letzte beschriebene Zelle wird ermittelt (jedes Mal neu, da jedes Mal eine neue Spalte  _
beschrieben wird und sich der Wert dadurch ändert)
letztespalteZiel = Sheets("Daten1").Cells(1, 256).End(xlToLeft).Column
'In die Spalte neben der letzten beschriebenen Spalte wird der variable Wert eingetragen
Cells(1, letztespalteZiel + 1).Value = variable
'Die Tabelle mit der Ursprungsdatei wird wieder geöffnet
Worksheets("Eingabe").Activate
End If
'Die nächste Spalte in den Rohdaten wird überprüft und übertragen
Next s
Sheets("Eingabe").Select
'Es wird geprüft, wie viele Zeilen es in der "Spalte B" gibt. Die "2" steht für den zweiten  _
Buchstaben im Alphabet (B)
LetzteZeile = ActiveSheet.Cells(1048576, 3).End(xlUp).Row
'In der Matrix werden alle "Fahrer" markiert.
Range("Matrix[Fahrer]").Select
'Die Auswahl wird kopiert
Selection.Copy
Sheets("Daten1").Select
'Die kopierte Auswahl wird in der "Spalte B" eingefügt (Ab der ersten Zeile)
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Eingabe").Select
'In der Matrix werden alle "Beifahrer" markiert.
Range("Matrix[Beifahrer]").Select
'Die Auswahl wird kopiert
Application.CutCopyMode = False
Selection.Copy
Sheets("Daten1").Select
'Die kopierten Beifahrer werden in "Spalte B" (2. Buchstabe im Alphabet) unter die  _
bereits vorhandenen Fahrer geschrieben
'Der Ausdruck "letztezeile-0" ist die erste freie Zelle unter den Fahrern
Range(Cells(LetzteZeile + 1, 2), Cells(LetzteZeile + 1, 2)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Application.CutCopyMode = False
Sheets("Eingabe").Select
'Es wird geprüft, wie viele Zeilen es in der "Spalte A" gibt. Die "1" steht für den ersten  _
Buchstaben im Alphabet (A)
LetzteZeile = ActiveSheet.Cells(1048576, 5).End(xlUp).Row
'In der Matrix werden alle "Datum" markiert.
Range("Matrix[Datum]").Select
'Die Auswahl wird kopiert
Selection.Copy
Sheets("Daten1").Select
'Die kopierte Auswahl wird in der "Spalte A" eingefügt (Ab der ersten Zeile)
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Eingabe").Select
'In der Matrix werden alle "Datum" markiert.
Range("Matrix[Datum]").Select
'Die Auswahl wird kopiert
Application.CutCopyMode = False
Selection.Copy
Sheets("Daten1").Select
'Die kopierten "Datum" werden in "Spalte A" (1. Buchstabe im Alphabet) unter die  _
bereits vorhandenen "Datum" geschrieben
'Der Ausdruck "letztezeile-0" ist die erste freie Zelle unter dem Datum
Range(Cells(LetzteZeile + 1, 1), Cells(LetzteZeile + 1, 1)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("AA:AA").Select
Application.CutCopyMode = False
'Der "eingefrorene" Bildschirm wird wieder freigeschaltet, damit die Änderungen sichtbar  _
werden
Application.ScreenUpdating = True
End Sub

Anzeige
AW: Tabelle anpassen / Spalte entfernen
22.05.2019 15:32:21
peterk
Hallo

LetzteSpalte = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column

AW: Tabelle anpassen / Spalte entfernen
22.05.2019 15:32:31
Torsten
Hallo,
die letzte benutzte Spalte, also das rechte Ende deiner Tabelle kannst du so ermitteln. Deine Zeile abaendern:
letztespalte = Sheets("Eingabe").Cells(1, Columns.Count).End(xlToLeft).Column
Gruss Torsten
AW: Tabelle anpassen / Spalte entfernen
22.05.2019 15:32:33
Torsten
Hallo,
die letzte benutzte Spalte, also das rechte Ende deiner Tabelle kannst du so ermitteln. Deine Zeile abaendern:
letztespalte = Sheets("Eingabe").Cells(1, Columns.Count).End(xlToLeft).Column
Gruss Torsten
Anzeige
Vielleicht nicht präzise genug
23.05.2019 10:49:53
Steve
Moin, Torsten
danke für die Hilfe. Wenn ich das richtig verstehe, dann stoppt dein Beitrag wenn das rechte Ende erreicht wurde. Ich habe das mal eingebaut aber bei dem Grundproblem bleibt es trotzdem.
Die Tabelle selber wird angelegt, aber nicht befüllt. Also die Überschriften sind da. Die Felder "Datum" und "Team" sind korrekt befüllt, aber nur weil ich das manuell erledigt habe.
Aber der Rest der Tabelle wird nicht befüllt. Ich habe die vage Vermutung, das ich eine Schleife erstellen muss die letztlich immer wieder dasselbe macht das ich schon mit dem Datum gemacht habe.
Also die Spalte erfassen, kopieren und einfügen und ein zweites mal unter der letzten Zeile einfügen.
Und das eben bis das rechte Ende der Tabelle erreicht ist.
Ich habe mal meinen Code aufgeräumt und sende den deshalb neu.
Sub Spalte()
Application.ScreenUpdating = False
'Pivot vorbereiten'
Sheets("Daten1").Select
Columns("A:ZZ").Select
Selection.Delete Shift:=xlToLeft
Range("A1:A2").Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$A$2"), , xlYes).Name = "Datum"
Columns("A:A").Select
Selection.NumberFormat = "dd/mm/yy;@"
Worksheets("Eingabe").Activate
letztespalte = Sheets("Eingabe").Cells(1, 256).End(xlToLeft).Column
'Eingabe Sheet auswerten'
For s = 1 To letztespalte
Eingabe = Cells(1, s).Value
'Wenn der Inhalt der geprüften Zelle nicht Fahrer oder Beifahrer ist, dann wird der Inhalt der  _
Zelle in die Variable aufgenommen
'Ansonsten wird die Prozedur übersprungen und es wird zum "End if" (siehe Ende des Makros)  _
gesprungen
If Cells(1, s).Value  "Fahrer" And Cells(1, s).Value  "Beifahrer" And Cells(1, s). _
Value  "Datum" Then
variable = Cells(1, s).Value
'Die Überschriften "Datum" und "Team" werden vorgegeben.
Worksheets("Daten1").Activate
Cells(1, 1).Value = "Datum"
Worksheets("Daten1").Activate
Cells(1, 2).Value = "Team"
'die restlichen Überschriften werden übernommen
letztespalteZiel = Sheets("Daten1").Cells(1, 256).End(xlToLeft).Column
Cells(1, letztespalteZiel + 1).Value = variable
Worksheets("Eingabe").Activate
End If
Next s
'Datensätze werden übertragen'
'FAHRER und BEIFAHRER'
'Der erste Datensatz "Fahrer" wird geschrieben'
Sheets("Eingabe").Select
LetzteZeile = ActiveSheet.Cells(1048576, 3).End(xlUp).Row
Range("Matrix[Fahrer]").Select
Selection.Copy
Sheets("Daten1").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'"Beifahrer" werden unter dem letzten Eintrag der "Fahrer" hinzugefügt
Sheets("Eingabe").Select
Range("Matrix[Beifahrer]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Daten1").Select
Range(Cells(LetzteZeile + 1, 2), Cells(LetzteZeile + 1, 2)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Application.CutCopyMode = False
'DATUM'
'Der erste Datensatz "Datum" wird geschrieben'
Sheets("Eingabe").Select
LetzteZeile = ActiveSheet.Cells(1048576, 5).End(xlUp).Row
Range("Matrix[Datum]").Select
Selection.Copy
Sheets("Daten1").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'"Datum" werden unter dem letzten Eintrag der "Datum" hinzugefügt
Sheets("Eingabe").Select
Range("Matrix[Datum]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Daten1").Select
Range(Cells(LetzteZeile + 1, 1), Cells(LetzteZeile + 1, 1)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("AA:AA").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Liebe Grüße
Steve
Anzeige
AW: Vielleicht nicht präzise genug
23.05.2019 11:36:06
Torsten
Hallo Steve,
es waere glaub ich einfacher, wenn du mal deine Datei mit anonymisierten Daten oder Beispieldaten als Beispieldatei hochlaedst.
Es ist schwer, den Code nachzuvollziehen, wenn man nicht weiss, wie die Tabellen dazu aussehen.
Gruss Torsten
AW: Vielleicht nicht präzise genug
23.05.2019 12:04:08
Steve
Hallo Torsten,
das mache ich gerne. Hier ist die Datei.
Vielen Dank schon einmal fürs anschauen.
https://www.herber.de/bbs/user/129981.xlsm
Liebe Grüße
Steve
Anfrage NEU
28.05.2019 09:45:52
Steve
Moin,
Ich versuche es mal einfacher. Ich möchte einen Code erstellen der in der Lage ist aus jedweder Tabelle unabhängig von ihrer Länge und Breite eine Neue Tabelle zu generieren die folgende Spezifikationen erfüllt.
In Spalte A und B der alten Tabelle stehen Namen. Diese sollen in der neuen Tabelle nur noch in Spalte A stehen. Alle dazugehörigen Werte sollen entsprechend mit übernommen werden.
Genau genommen muss also die Tabelle dupliziert und unten angefügt werden. Wie schon erwähnt habe ich einiges davon bereits umsetzen können. Datum, Name und auch die Tabellenüberschriften werden wohl übernommen. Was aber in meinem Code fehlt weil ich nicht weiss wie ich es umsetzen soll ist die Frage wie ich die restlichen Werte übernehmen soll.
Kann mir da vielleicht jemand helfen?
Beispiel
ALT:
_____A_________B________C________D
___Name 1___Name 2___Datum 1___Wert 1
___Name 3___Name 2___Datum 2___Wert 2
NEU:
_____A_________B________C
___Datum 1___Name 1___Wert 1
___Datum 2___Name 3___Wert 2
___Datum 1___Name 2___Wert 1
___Datum 2___Name 2___Wert 2
LG Grüße und danke für eure Mühe und Anregungen
Steve
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige