Pivot-Tabelle aus mehreren Dateien

Sub PivotT_online_weekly()
' Makro1 Makro
' Makro am 28.06.2006 von Admin aufgezeichnet
' und händisch geändert
Dim zei As Long
Dateiname = ActiveWorkbook.Name 'Dateiname Deklarieren
'Alle Daten in eine neue Datei
Cells.Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
'Pivot-Tabelle der Datenquelle
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Tabelle1!AA:AE").CreatePivotTable TableDestination:="", TableName:= _
"PivotTable1"
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable1").SmallGrid = False
ActiveSheet.PivotTables("PivotTable1").AddFields RowFields:=Array("AGENT", _
"Daten")
With ActiveSheet.PivotTables("PivotTable1").PivotFields("ZIELPERSON_ERREICHT")
.Orientation = xlDataField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("VERKAUF")
.Orientation = xlDataField
.Position = 2
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("ERREICHT_NEGATIV")
.Orientation = xlDataField
.Position = 3
End With
ActiveSheet.PivotTables("PivotTable1").PivotFields("GRUND_NICHT_ERREICHT"). _
Orientation = xlDataField
Range("B3").Select
ActiveSheet.PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel
ActiveSheet.PivotTables("PivotTable1").Format xlReport4
Range("A1").Select
'Pivot-Tabelle entschärfen
Cells.Select
Selection.Copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
'Formatieren
Range("B3").Select
'Text umbrechen, damit es schmaler wird
ActiveCell.FormulaR1C1 = "Anzahl" & Chr(10) & "ZIELPERSON" & Chr(10) & "ERREICHT"
With ActiveCell.Characters(Start:=1, Length:=26).Font
.Name = "MS Sans Serif"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With
Range("C3").Select
'Text umbrechen, damit es schmaler wird
ActiveCell.FormulaR1C1 = "Anzahl" & Chr(10) & "VERKAUF"
With ActiveCell.Characters(Start:=1, Length:=14).Font
.Name = "MS Sans Serif"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With
Range("D3").Select
'Text umbrechen, damit es schmaler wird
ActiveCell.FormulaR1C1 = "Anzahl " & Chr(10) & "ERREICHT" & Chr(10) & "NEGATIV"
With ActiveCell.Characters(Start:=1, Length:=24).Font
.Name = "MS Sans Serif"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With
Range("E3").Select
'Text umbrechen, damit es schmaler wird
ActiveCell.FormulaR1C1 = "Anzahl" & Chr(10) & "NICHT" & Chr(10) & "ERREICHT"
With ActiveCell.Characters(Start:=1, Length:=21).Font
.Name = "MS Sans Serif"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With
'Einsetzen einer Spalte für Prozentsatz "VERKAUF"
Range("D3").Select
Selection.EntireColumn.Insert
ActiveCell.FormulaR1C1 = "Anteil" & Chr(10) & "VERKAUF"
'Einsetzen einer Spalte für Prozentsatz "ERREICHT - NEGATIV"
Range("F3").Select
Selection.EntireColumn.Insert
ActiveCell.FormulaR1C1 = "Anteil" & Chr(10) & "ERREICHT" & Chr(10) & "NEGATIV"
For zei = 4 To Range("A65536").End(xlUp).Row
'Einsetzen der Formel für Prozentsatz "VERKAUF"
Cells(zei, 4).FormulaR1C1 = "=RC[-1]*100/RC[-2]"
Cells(zei, 4).NumberFormat = "0.00"" %"""
'Einsetzen der Formel für Prozentsatz "ERREICHT - NEGATIV"
Cells(zei, 6).FormulaR1C1 = "=RC[-1]*100/RC[-4]"
Cells(zei, 6).NumberFormat = "0.00"" %"""
Next zei
'Zeilen in denen in Spalte A "(Leer)" ist, werden gelöscht
ende = Cells(Rows.Count, 1).End(xlUp).Row 'die 1 steht für die Spalte A
For i = ende To 2 Step -1
If Cells(i, 1) = "(Leer)" Then
Rows(i).Delete
End If
Next i
Range("A1").Select
'Spaltenbreite anpassen
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Range("C1").Select
'Datum holen
ActiveCell.Value = Dateiname
'in weisser Schrift
With ActiveCell.Characters.Font
.Name = "MS Sans Serif"
.FontStyle = "Fett"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With
Range("B1").Select
ActiveCell.FormulaR1C1 = "=(MID(RC[1],12,5))&"" - ""&(MID(RC[1],7,4))"
Range("A1").Select
ActiveCell.FormulaR1C1 = "Auswertung vom"
Range("A1:B1").Select
Selection.Font.Bold = True
Range("A2").Select
'Datei vereinfachen
Application.DisplayAlerts = False
'Überflüssige Tabellen löschen
Sheets(Array("Tabelle1", "Tabelle2", "Tabelle3")).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'Verbliebene Tabelle umbenennen
Sheets("Tabelle4").Select
Sheets("Tabelle4").Name = Range("B1").Value
Application.CutCopyMode = False
Range("A1").Select
End Sub