Ein neues Tabellenblatt wird erstellt und bekommt den Namen "Gesamt".
Hier noch eine Beispieldatei mit 160 Tabellenblätter:
Viele Tabellenblätter - Viele Zellen - Gesamtübersicht... [ZIP 6 MB]
Option Explicit '-------------------------------------------------------------------------- ' Module : Modul1 ' Procedure : Main ' Author : Case (Ralf Stolzenburg) ' Date : 30.10.2012 ' Purpose : Array - Viele Tabellenblätter - Zellen - Gesamtübersicht '-------------------------------------------------------------------------- Public Sub Main() ' Variablendeklaration Dim wksSheetAll As Worksheet Dim wksSheet As Worksheet Dim varArr() As Variant Dim intCount As Integer Dim strCells As String Dim lngLastRow As Long Dim intCalc As Integer Dim rngRange As Range Dim lngCount As Long On Error GoTo Fin ' Die Applikation ruhig stellen With Application .ScreenUpdating = False .AskToUpdateLinks = False .EnableEvents = False intCalc = .Calculation .Calculation = xlCalculationManual .DisplayAlerts = False End With ' Das Array grösser als der zu erwartende Inhalt dimensionieren ' Damit sparen wir uns ein "ReDim Preserve" IN der For-Schleife Redim varArr(10000) ' Neues Tabellenblatt erstellen Set wksSheetAll = ThisWorkbook.Worksheets.Add ' Neues Tabellenblatt an den Anfang stellen wksSheetAll.Move Before:=ThisWorkbook.Worksheets(1) ' Neues Tabellenblatt bekommt den Mamen "Gesamt" wksSheetAll.Name = "Gesamt" ' Die auszulesenden Zellen der jeweiligen Tabellenblätter strCells = "A2,B11,G11,M11,B19,G19,M19,B28,G28,M28,B34,G34,M34,B41,G41,M41" ' Für jedes Tabellenblatt in der Mappe in der das Makro gestartet wurde For Each wksSheet In ThisWorkbook.Worksheets ' Beginne mit Tabellenblatt ab der 2ten Stelle If wksSheet.Index > 1 Then ' Beziehe dich auf dieses Blatt With wksSheet ' Jede Zelle der Variablen strCells wird berücksichtigt For Each rngRange In .Range(strCells) ' Letzte belegte Zelle Spalte F und PLUS 1 lngLastRow = IIf(IsEmpty(wksSheetAll.Cells _ (wksSheetAll.Rows.Count, 1)), wksSheetAll.Cells _ (wksSheetAll.Rows.Count, 1).End(xlUp).Row, _ wksSheetAll.Rows.Count) + 1 ' Array befüllen varArr(lngCount) = rngRange.Value ' Laufvariable hochsetzen lngCount = lngCount + 1 Next rngRange End With ' Array wird auf die tatsächliche Grösse reduziert Redim Preserve varArr(lngCount) ' Daten in Tabelle "Gesamt" aus Array eintragen wksSheetAll.Cells(lngLastRow, intCount + 1).Resize _ (, Ubound(varArr)) = varArr ' Laufvariable für nächsten Durchlauf zurück setzen lngCount = 0 End If Next wksSheet Fin: ' Objektvariable leeren Set wksSheetAll = Nothing With Application ' Die Applikation aufwecken .ScreenUpdating = True .AskToUpdateLinks = True .EnableEvents = True .Calculation = intCalc .DisplayAlerts = True End With If Err.Number <> 0 Then MsgBox "Error: " & _ Err.Number & " " & Err.Description End Sub