AW: Top Ten
07.08.2003 11:57:15
Lothar
Hallo Bob!
Hier der komplette Source Code:
Voraussetzung: Das 1. Tabellenblatt heisst Steuerung (da war bei mir der TestButtom drauf :) der das Makro aufruft.
Sub KopierenSortierenFilternAusgeben()
Dim iCounter As Integer, iRow As Integer, nName as String
Application.ScreenUpdating = False
Sheets("Steuerung").Select
nName = "TopTen"
Blattname = nName
For Each Blatt In Sheets
If Blatt.Name = Blattname Then
Sheets("Steuerung").Select
If MsgBox( _
prompt:="Das Blatt " & nName & " exisitert schon!" & Chr(13) & Chr(10) & "NEIN = Weiterverarbeitung abbrechen!" & Chr(13) & Chr(10) & "JA = Update! (Löschung vorhandenes Blatt, Ersetzung mit neuen Daten!)", _
Buttons:=vbQuestion + vbYesNo + vbDefaultButton2 _
) = vbNo Then Exit Sub
Sheets(nName).Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End If
Next
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = nName
iRow = 1
For iCounter = 2 To 4 ' hier muss bei 18 Blättern natürlich 19 stehen !!
Worksheets(iCounter).Range("A1").CurrentRegion.Copy _
Cells(iRow, 1)
iRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Next iCounter
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Name"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Tore"
Range("A1:B1").Select
Selection.Font.Bold = True
Cells.Select
Selection.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("B1").Select
Selection.AutoFilter Field:=2, Criteria1:="10", Operator:=xlTop10Items
Application.ScreenUpdating = True
End Sub