AW: Bereiche in separates sheet
29.07.2008 01:26:00
Tino
Hallo,
test mal diesen Code.
Kopiert alle Tabellen nach Total und Sortiert diese nach nicht leeren Zellen,
dafür wird die letzte Spalte im Tabellenblatt benutzt, diese wird zum Schluss wieder gelöscht.
'Kopiert alle Tabellen nach Total
Sub KopiereTabellen()
Dim objTab As Worksheet
Application.ScreenUpdating = False
Sheets("Total").Cells.Clear
With Sheets("Total")
For Each objTab In ThisWorkbook.Worksheets
If objTab.Name "Total" Then
objTab.UsedRange.Copy
.Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row + 1, 1) _
.End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next objTab
.Select
End With
Call SortiereNachLeer
Application.ScreenUpdating = True
Range("A1").Select
End Sub
'Sortiert um die Leeren Zeilen zu entfernen
Sub SortiereNachLeer()
Dim Bereich As Range
With Sheets("Total")
Set Bereich = .Range("A1", "A" & .Cells.SpecialCells _
(xlCellTypeLastCell).Row).Offset(0, Columns.Count - 1)
Bereich.FormulaR1C1 = "=IF(COUNTA(RC1:RC[-1])>0,ROW(),"""")"
Bereich.Value = Bereich.Value
Rows("1:" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Sort _
Key1:=.Cells(1, .Columns.Count), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Bereich.ClearContents
End With
End Sub
Gruß Tino
www.VBA-Excel.de