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"
Private
Const
MeineTabelle
As
String
=
"Tabelle1"
Private
Const
ZeileW1
As
Long
= 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"
Private
Dateiliste()
As
String
Private
Dateizähler
As
Long
Sub
Annafest()
Dim
UnterVerz
As
Object
Dim
UnterPfad
As
String
Dim
x
As
Long
Dim
y
As
Long
Dim
mStr
As
String
Dim
tStr
As
String
Dim
aStr
As
String
Rem ggf. nur Zusammenfassung zeigen
aStr =
"Neubeginn - aktuelles Blatt löschen ?"
If
ActiveWorkbook.Sheets.Count > 1
Then
aStr = aStr & Chr(13)
aStr = aStr &
"(bei Nein wird eine Zusammenfassung ermittelt)"
End
If
Rem Sicherheitsabfrage
Select
Case
MsgBox(aStr, vbYesNo,
"Hinweis"
)
Case
6
Case
7
If
ActiveWorkbook.Sheets.Count > 1
Then
Zusammenfassung
Exit
Sub
Case
Else
Exit
Sub
End
Select
Rem OK, dann los
ActiveSheet.Cells.Clear
ActiveSheet.Cells.ClearContents
Application.ScreenUpdating =
False
Rem bastle eine Überschrift für die spätere Auswertung
Überschrift
[A2].Value = ActiveWorkbook.Path
Columns(1).AutoFit
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
Set
UnterVerz = CreateObject(
"Shell.Application"
).BrowseForFolder _
(0,
"Den Unterordner auswählen oder Abbruch"
, 0, ActiveWorkbook.Path)
If
UnterVerz
Is
Nothing
Then
GoTo
errorhandler
UnterPfad = UnterVerz.self.Path
UnterPfad = UnterPfad & "\"
[B2].Value = UnterPfad
Columns(2).AutoFit
Rem Blattname ändern
tStr = Replace(UnterPfad, [A2].Value,
""
)
tStr = Replace(tStr,
"\", "
")
tStr = Replace(tStr,
" "
,
""
)
ActiveSheet.Name = tStr
Rem die Mappen im Unterordner
Dateizähler = 0
MappenSuche UnterPfad,
"*.xl*"
If
Dateizähler = 0
Then
GoTo
errorhandler
Rem in die Tabelle schreiben
y = 0
For
x = 0
To
Dateizähler - 1
If
Dateiliste(0, x) = MeineDatei
Then
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
End
If
Next
x
Rem jetzt die Werte dazu - aus jedem Blatt F2 = 2/6 und F3 = 3/6 (Zeile/Spalte)
y = 0
For
x = 0
To
Dateizähler - 1
If
Dateiliste(0, x) = MeineDatei
Then
[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
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
Application.ScreenUpdating =
True
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
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