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