alle Zeilen kopieren

Hallo,
über den untenstehenden Code erreiche ich, dass aus den Tabellen 1 und 2 die beschriebenen Zeilen in Tabelle 3 kopiert werden. Meine Arbeitsmappe enthält oftmals eine unterschiedliche Anzahl an Tabellen.- Wie müßte ich den Code umstellen, wenn aus allen in der Mappe befindlichen Tabellenblättern die Zeilen -ab Zeile 2- (Zeile 1 ist jeweils Überschrift) in ein verdecktes Tabellenblatt "Temp" kopiert werden sollen und in der Folge dann alphabetisch -Spalte A- sortiert werden sollen? - Ausgespart werden müßten dabei die Tabellenblätter "Daten" und "Hinweise". Kann mir da jemand helfen? - Danke schon jetzt für die Rückmeldungen.
Herzliche Grüße
Wolfgang


Sub ZusammenFuehren()
Dim shTarget As Worksheet
Dim rngSourceA As Range, rngSourceB As Range
Dim intRow As Integer, intCounter As Integer, intCol
Application.ScreenUpdating = False
Set rngSourceA = Worksheets("Tabelle1").Range("A1").CurrentRegion
Set rngSourceB = Worksheets("Tabelle2").Range("A1").CurrentRegion
Set shTarget = Worksheets("Tabelle3")
intCol = rngSourceA.Columns.Count
If rngSourceB.Columns.Count > intCol Then
intCol = rngSourceB.Columns.Count
End If
For intCounter = 1 To intCol
shTarget.Cells(1, intCounter) = "Spalte" & intCounter
Next intCounter
shTarget.Rows(1).Font.Bold = True
rngSourceA.Range("A1").CurrentRegion.Copy shTarget.Range("A2")
intRow = shTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
rngSourceB.Range("A1").CurrentRegion.Copy shTarget.Cells(intRow, 1)
shTarget.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=shTarget.Cells(1, shTarget.UsedRange.Columns.Count + 1), _
Unique:=True
shTarget.Range(shTarget.Cells(1, 1), shTarget.Cells(1, intCol)). _
EntireColumn.Delete
shTarget.Columns.AutoFit
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim rngQuelle() As Range, i As Integer, y As Integer, Wb As Workbook, wsZiel As Worksheet Set Wb = ThisWorkbook Set wsZiel = Wb.Worksheets("Temp") ReDim rngQuelle(Wb.Worksheets.Count) For i = 1 To Wb.Worksheets.Count With Wb.Worksheets(i) Select Case .Name Case "Daten", "Hinweise", wsZiel.Name Case Else Set rngQuelle(y) = .Range("A2:" & .Cells.SpecialCells(xlCellTypeLastCell).Address) y = y + 1 End Select End With Next ReDim Preserve rngQuelle(y - 1) For i = LBound(rngQuelle) To UBound(rngQuelle) rngQuelle(i).Copy Destination:=wsZiel.Range("A65536").End(xlUp).Offset(1, 0) Next wsZiel.UsedRange.Sort key1:=wsZiel.Range("A2"), order1:=xlAscending, header:=xlYes End Sub

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread