Thema Datum  Von Nutzer Rating
Antwort
14.02.2014 11:22:03 Anna
NotSolved
15.02.2014 00:25:54 H27
NotSolved
Rot Dateien aus mehreren Ordnern importieren und dann weiterrechnen
15.02.2014 11:27:46 H27
NotSolved
05.05.2014 11:58:22 Fabi
NotSolved

Ansicht des Beitrags:
Von:
H27
Datum:
15.02.2014 11:27:46
Views:
1105
Rating: Antwort:
  Ja
Thema:
Dateien aus mehreren Ordnern importieren und dann weiterrechnen

1 x einfach und geschmacklos (Metalliclackierungnur gegen Aufpreis)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
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 'OK
  Case '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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
14.02.2014 11:22:03 Anna
NotSolved
15.02.2014 00:25:54 H27
NotSolved
Rot Dateien aus mehreren Ordnern importieren und dann weiterrechnen
15.02.2014 11:27:46 H27
NotSolved
05.05.2014 11:58:22 Fabi
NotSolved