Viele Tabellenblätter - Viele Zellen - Gesamtübersicht

Frage: Aus sehr vielen Tabellenblättern sollen sehr viele Zellen in ein neu zu erstellendes Tabellenblatt gebracht werden. Die Zellen sind "A2, B11, G11, M11, B19, G19, M19, B28, G28, M28, B34, G34, M34, B41, G41, M41". Wie geht das?

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