Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
976to980
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
976to980
976to980
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Mehrere Listen untereinanderschreiben

Mehrere Listen untereinanderschreiben
14.05.2008 16:25:00
Karsten
Hallo zusammen,
Ich habe ein Tabellenblatt, indem ich verschiedene Listen habe, die eine variable Länge haben. Nun möchte ich eine "Endliste" erstellen, in der die Ausgangslisten untereinander geschrieben werden.
https://www.herber.de/bbs/user/52350.xls
In der Beispieldatei sind nur 3 Listen geschrieben, jedoch sollte die Möglichkeit, wie man dieses Problem löst, auch auf mehr als nur 3 zusammenzuschreibende Listen funktionieren.
Danke für die Bemühungen
Gruß
Karsten

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Mehrere Listen untereinanderschreiben
14.05.2008 16:59:10
Mister
Hallo Karsten,
vielleicht als Ansatz.

Sub SuchListe()
Dim lEnd As Long
Dim Zeile As Long
Dim x As Integer
Dim y As Integer
Dim z As Integer
With Application
.ScreenUpdating = False
End With
With Sheets("Tabelle1")
x = .Cells(65536, 3).End(xlUp).Row
For Zeile = 6 To x
Sheets("Schnellsuche").Cells(Zeile - 5, 1) = .Cells(Zeile, "C") & IIf(Not IsEmpty(.Cells(Zeile,  _
"D")), ", " _
& .Cells(Zeile, "D"), "")
Sheets("Schnellsuche").Cells(Zeile - 5, 2) = .Cells(Zeile, "E")
Sheets("Schnellsuche").Cells(Zeile - 5, 3) = .Cells(Zeile, "F")
Sheets("Schnellsuche").Cells(Zeile - 5, 4) = .Cells(Zeile, "G")
Sheets("Schnellsuche").Cells(Zeile - 5, 5) = .Cells(Zeile, "H")
Sheets("Schnellsuche").Cells(Zeile - 5, 6) = .Cells(Zeile, "I")
Sheets("Schnellsuche").Cells(Zeile - 5, 7) = .Cells(Zeile, "J")
Sheets("Schnellsuche").Cells(Zeile - 5, 21) = .Cells(Zeile, "U")
Sheets("Schnellsuche").Cells(Zeile - 5, 22) = .Cells(Zeile, "W")
Sheets("Schnellsuche").Cells(Zeile - 5, 23) = .Cells(Zeile, "C")
Sheets("Schnellsuche").Cells(Zeile - 5, 24) = .Cells(Zeile, "D")
Sheets("Schnellsuche").Cells(Zeile - 5, 25) = .Cells(Zeile, "X")
Next
End With
With Sheets("Tabelle2")
y = .Cells(65536, 3).End(xlUp).Row
For Zeile = 6 To y
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 1) = .Cells(Zeile, "C") & IIf(Not IsEmpty(. _
Cells(Zeile, "D")), ", " _
& .Cells(Zeile, "D"), "")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 2) = .Cells(Zeile, "E")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 3) = .Cells(Zeile, "F")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 4) = .Cells(Zeile, "G")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 5) = .Cells(Zeile, "H")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 6) = .Cells(Zeile, "I")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 7) = .Cells(Zeile, "J")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 21) = .Cells(Zeile, "U")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 22) = .Cells(Zeile, "W")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 23) = .Cells(Zeile, "C")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 24) = .Cells(Zeile, "D")
Sheets("Schnellsuche").Cells(551 + (Zeile - 5), 25) = .Cells(Zeile, "X")
Next
End With
With Sheets("Tabelle3")
z = .Cells(65536, 3).End(xlUp).Row
For Zeile = 6 To z
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 1) = .Cells(Zeile, "C") & IIf(Not IsEmpty(. _
Cells(Zeile, "D")), ", " _
& .Cells(Zeile, "D"), "")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 2) = .Cells(Zeile, "E")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 3) = .Cells(Zeile, "F")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 4) = .Cells(Zeile, "G")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 5) = .Cells(Zeile, "H")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 6) = .Cells(Zeile, "M")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 7) = .Cells(Zeile, "N")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 21) = .Cells(Zeile, "X")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 22) = .Cells(Zeile, "Z")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 23) = .Cells(Zeile, "C")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 24) = .Cells(Zeile, "D")
Sheets("Schnellsuche").Cells(1101 + (Zeile - 5), 25) = .Cells(Zeile, "AA")
Next
End With
With Sheets("Schnellsuche")
.Unprotect
.Columns.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
.Protect
Application.ScreenUpdating = True
End With
End Sub


Dieses Marko fügt die Tabellen 1 - 3 in eine neue Tabelle (Schnellsuche) zusammen und sortiert das ganze. Vielleicht kannst du etwas damit anfangen....
Gruß
Martin

Anzeige
AW: Mehrere Listen untereinanderschreiben
14.05.2008 17:12:00
Karsten
Hallo,
Danke für das Makro.
Leider kenne ich mich nicht gut genug mit Makros aus, alsdass ich verstehen könnte, was ich ändern muss, damit das Makro funktioniert. Es wäre gut, wenn es ein Makro wäre, welches genau auf die Tabelle passt.
Gruß
Karsten

AW: Mehrere Listen untereinanderschreiben
14.05.2008 17:31:20
Reinhard
Hi Karsten,
im Blatt Anfangslisten Rechtsklick unten auf den Blattnamen, Code anzeigen, dorthinein diesen Code:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Column + 1) Mod 3  0 Then Exit Sub ' wenn Spalte nicht 2, 5, 8, 11,... dann exit
Call Liste
End Sub


Einfügen---Modul, dorthinein diesen Code:


Option Explicit
Sub Liste()
Dim wks1, wks2, Zei1, Spa1, Zei2
Set wks1 = Worksheets("Anfangslisten")
Set wks2 = Worksheets("Endliste")
With wks2
.UsedRange.ClearContents
For Spa1 = 2 To wks1.Cells(3, Columns.Count).End(xlToLeft).Column Step 3
Zei1 = wks1.Cells(Rows.Count, Spa1).End(xlUp).Row
wks1.Range(Cells(1, Spa1 - 1), Cells(Zei1, Spa1)).Copy Destination:=.Cells(Zei2 + 1, 1)
Zei2 = .Cells(Rows.Count, 2).End(xlUp).Row + 1
Next Spa1
End With
End Sub


Editor schließen.
Jede Veränderung in Spalte B,E,H,... löst die Listenerstellung im Blatt Endliste aus.
Gruß
Reinhard

Anzeige
AW: Mehrere Listen untereinanderschreiben
14.05.2008 17:36:00
Karsten
Hallo Reinhard,
Vielen Dank, das Makro funktioniert sehr gut.
Danke und Gruß
Karsten

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige