wer kann mir helfen, ich möchte aus 175 tabellen in einer datei automatisch eine machen... geht das?
Danke Gruss
M.
Option Explicit
Sub TabellenKonsolidieren()
Dim wbZiel As Workbook, wksZiel As Worksheet, ZeileZiel As Long, Bereich As Range
Dim wbQuelle As Workbook, wksQuelle As Worksheet, intI As Integer
Dim StatusCalc As Long
'Aktive Arbeitsmappe als Datenquelle festlegen
Set wbQuelle = ActiveWorkbook
'alle Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
'Tabellenblätter in Quelle abarbeiten
For intI = 1 To wbQuelle.Worksheets.Count
Application.StatusBar = "Bearbeite Blatt " & intI & " von " & wbQuelle.Worksheets.Count
Set wksQuelle = wbQuelle.Worksheets(intI)
'Prüfen, ob Blatt leer
If Not (wksQuelle.Cells.SpecialCells(xlCellTypeLastCell).Columns = 1 _
And IsEmpty(wksQuelle.Cells.SpecialCells(xlCellTypeLastCell))) Then
If wbZiel Is Nothing Then
'1. Blatt in neue Arbeitsmappe kopieren, so passen die Spaltenformate
wbQuelle.Worksheets(intI).Copy
Set wbZiel = ActiveWorkbook
Set wksZiel = ActiveSheet
With wksZiel
'Blatt umbenennen
.Name = "Zusammenfassung"
'Formeln durch Werte ersetzen
Set Bereich = wksZiel.Range(.Cells(1, 1), .Cells.SpecialCells(xlCellTypeLastCell))
'Formeln durch Werte ersetzen
Bereich.Copy
Bereich.PasteSpecial Paste:=xlValues
End With
Else
'Nächste freie Zeile im Zielblatt ermitteln
ZeileZiel = wksZiel.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
'Datenbereich in Quelle ermitteln und kopieren
With wksQuelle
Set Bereich = wksQuelle.Range(.Cells(1, 1), .Cells.SpecialCells(xlCellTypeLastCell))
End With
Bereich.Copy
'Formate und Werteeinfügen
wksZiel.Cells(ZeileZiel, 1).PasteSpecial Paste:=xlFormats
wksZiel.Cells(ZeileZiel, 1).PasteSpecial Paste:=xlValues
End If
End If
Next
Application.CutCopyMode = False
'Makrobremsen zurücksetzen
With Application
.StatusBar = False
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
MsgBox "Fertig"
End Sub