1 x einfach und geschmacklos (Metalliclackierungnur gegen Aufpreis)

Option Explicit
Rem die Auswertungsmappe sollte zu Beginn nur "eine, einzige und leere" Tabelle1 haben, danach
Rem die Prozeduren in ein Modul kopieren
Rem danach kann beliebig gestartet werden

Private Const MeineDatei As String = "Results.xls"  'Wertedatei
Private Const MeineTabelle As String = "Tabelle1" 'Tabelle wo Werte
Private Const ZeileW1 As Long = 2 'Position wo Werte 1 u. 2
Private Const SpalteW1 As Long = 6
Private Const ZeileW2 As Long = 3
Private Const SpalteW2 As Long = 6
Private Const MeineFormel As String = "=RC[-2]/RC[-1]*100"  'Formel für Berechnungsspalte
Private Dateiliste() As String 'Sammelbehälter
Private Dateizähler As Long  'Zähler dazu

Sub Annafest()
Dim UnterVerz As Object 'der Unterordner ist ja variabel
Dim UnterPfad As String 'der Pfad zum Unterordner
Dim x As Long 'Zähler
Dim y As Long 'Zähler
Dim mStr As String  'Hilfstext
Dim tStr As String
Dim aStr As String

Rem ggf. nur Zusammenfassung zeigen
aStr = "Neubeginn - aktuelles Blatt löschen ?"  'für Sicherheitsabfrage
If ActiveWorkbook.Sheets.Count > 1 Then 'ggf. Zusammenfassung
  aStr = aStr & Chr(13)
  aStr = aStr & "(bei Nein wird eine Zusammenfassung ermittelt)"  'Textergänzung
End If

Rem Sicherheitsabfrage
Select Case MsgBox(aStr, vbYesNo, "Hinweis")
  Case 6  'OK
  Case 7  'Zusammenfassung
    If ActiveWorkbook.Sheets.Count > 1 Then Zusammenfassung
    Exit Sub
  Case Else 'Abbruch
    Exit Sub
End Select

Rem OK, dann los
ActiveSheet.Cells.Clear 'alles löschen
ActiveSheet.Cells.ClearContents 'wirklich alles

Application.ScreenUpdating = False  'Bildschirmausgabe aus

Rem bastle eine Überschrift für die spätere Auswertung
Überschrift

[A2].Value = ActiveWorkbook.Path  'denn hier ist diese Arbeitsmappe
Columns(1).AutoFit  'etwas schmuckvoller

Rem aktuelles Verzeichnis beibehalten
ChDrive Left(ActiveWorkbook.Path, InStr(ActiveWorkbook.Path, "\") - 1)

Rem den Unterordner auswählen - über das gezeigte Ordnerfenster den Probandenordner
On Error GoTo errorhandler  'Fehlerbehandlung
Set UnterVerz = CreateObject("Shell.Application").BrowseForFolder _
    (0, "Den Unterordner auswählen oder Abbruch", 0, ActiveWorkbook.Path)
If UnterVerz Is Nothing Then GoTo errorhandler  'war nix
UnterPfad = UnterVerz.self.Path 'wir haben ihn
UnterPfad = UnterPfad & "\" 'Backslash dazu
[B2].Value = UnterPfad  'in die Tabelle eintragen
Columns(2).AutoFit  'etwas schmuckvoller

Rem Blattname ändern
tStr = Replace(UnterPfad, [A2].Value, "") 'den Unterpfad auf ein Wort reduzieren
tStr = Replace(tStr, "\", "")
tStr = Replace(tStr, " ", "")
ActiveSheet.Name = tStr

Rem die Mappen im Unterordner
Dateizähler = 0 'rücksetzen
MappenSuche UnterPfad, "*.xl*" 'Aufruf Unterprozedur
If Dateizähler = 0 Then GoTo errorhandler 'keine Dateien

Rem in die Tabelle schreiben
y = 0 'als Zeilenzähler
For x = 0 To Dateizähler - 1  'Liste abarbeiten
  If Dateiliste(0, x) = MeineDatei Then 'nur die benannte Datei aufnehmen
    mStr = Dateiliste(1, x)
    mStr = Replace(mStr, [B2].Value, "")
    mStr = Left(mStr, InStr(mStr, "\") - 1)
    [B2].Offset(y, 1).Value = mStr
    [B2].Offset(y, 2).Value = "\"
    [B2].Offset(y, 3).Value = Dateiliste(0, x)
    y = y + 1 'als Zeilenzähler
  End If
Next x

Rem jetzt die Werte dazu - aus jedem Blatt F2 = 2/6 und F3 = 3/6 (Zeile/Spalte)
y = 0 'als Zeilenzähler
For x = 0 To Dateizähler - 1
  If Dateiliste(0, x) = MeineDatei Then 'nur die benannte Datei aufnehmen
    [E2].Offset(y, 1).Value = MitExcel4Macro(Dateiliste(1, x), ZeileW1, SpalteW1)
    [E2].Offset(y, 2).Value = MitExcel4Macro(Dateiliste(1, x), ZeileW2, SpalteW2)
    [E2].Offset(y, 3).FormulaR1C1 = MeineFormel
    y = y + 1 'als Zeilenzähler
  End If
Next x

Rem zum Schluss die Statistik
[I2].Value = WorksheetFunction.Average(Range([H2], [H2].End(xlDown)))
[J2].Value = WorksheetFunction.StDev(Range([H2], [H2].End(xlDown)))
Range(Columns(1), Columns(10)).AutoFit 'etwas schmuckvoller


Application.ScreenUpdating = True  'Bildschirmausgabe ein
aStr = "Daten wurden übernommen,"
aStr = aStr & Chr(13)
aStr = aStr & "(für ggf. weitere Unterverzeichnisse ein neues Tabellenblatt)"
MsgBox aStr
Exit Sub
errorhandler:
MsgBox "Abbruch wegen fehlender / falscher Angaben !"
Set UnterVerz = Nothing
Application.ScreenUpdating = True  'Bildschirmausgabe ein
End Sub

Private Function MitExcel4Macro(ausDatei As String, inZeile As Long, inSpalte As Long) As Variant
Dim mDatei As String
Dim mWert As Variant
On Error Resume Next
mDatei = Chr(39) & _
  Left(ausDatei, InStrRev(ausDatei, "\")) & Chr(91) & _
  Mid(ausDatei, InStrRev(ausDatei, "\") + 1) & Chr(93) & _
  MeineTabelle & Chr(39) & Chr(33)
  mWert = ExecuteExcel4Macro( _
    mDatei & Cells(inZeile, inSpalte).Address(ReferenceStyle:=xlR1C1))
On Error GoTo 0
MitExcel4Macro = mWert
End Function

Private Sub MappenSuche(imOrdner As String, Suchbegriff As String)
    Dim oOrdner As Object
    Dim oDatei As Object
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    For Each oDatei In oFSO.GetFolder(imOrdner).Files
        If oDatei.Name Like Suchbegriff Then
            ReDim Preserve Dateiliste(0 To 1, Dateizähler)
            Dateiliste(0, Dateizähler) = oDatei.Name
            Dateiliste(1, Dateizähler) = oDatei.Path
            Dateizähler = Dateizähler + 1
        End If
    Next
    For Each oOrdner In oFSO.GetFolder(imOrdner).Subfolders
        MappenSuche imOrdner & "\" & oOrdner.Name, Suchbegriff
    Next

End Sub

Private Sub Überschrift()
With Range("A1:J1")
  .NumberFormat = "@"
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
End With
With Range("A1:J1").Font
    .FontStyle = "Fett"
    .Size = 9
End With
[a1].Formula = "Verzeichnis"
[B1].Formula = "Proband_Vz"
[C1].Formula = "UnterVz"
[E1].Formula = "Datei"
[F1].Formula = "F2"
[G1].Formula = "F3"
[H1].Formula = "Berechnung"
[I1].Formula = "Mittelwert"
[J1].Formula = "Standardabw."
End Sub

Private Sub Zusammenfassung()
Dim x As Long
Dim y As Long
Dim z As Long
Dim a As Long
Dim mAllW() As Double
Dim mErg As String
For x = 1 To ActiveWorkbook.Sheets.Count
  y = 1
  On Error Resume Next
  y = ActiveWorkbook.Sheets(x).Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
  On Error GoTo 0
  For z = 2 To y
    ReDim Preserve mAllW(0 To a)
    mAllW(a) = ActiveWorkbook.Sheets(x).Cells(y, 8).Value
    a = a + 1
  Next z
Next x
mErg = "Ergebnis über " & CStr(ActiveWorkbook.Sheets.Count) & " Tabellen"
mErg = mErg & Chr(13)
mErg = mErg & "Mittelwert " & CStr(WorksheetFunction.Average(mAllW))
mErg = mErg & Chr(13)
mErg = mErg & "Standardabweichung " & CStr(WorksheetFunction.StDev(mAllW))
mErg = mErg & Chr(13)
MsgBox mErg
End Sub