Thema Datum  Von Nutzer Rating
Antwort
Rot Stundenzettel: Makro nimmt nicht alle SubFolder (Hauptordner auswählbar)
 17.02.2015 12:33:39 Daniel
NotSolved
17.02.2015 19:37:13 MarkusK
Solved
17.02.2015 21:20:10 Daniel
NotSolved
18.02.2015 08:42:42 Daniel
Solved

Ansicht des Beitrags:
Von:
Daniel		 Datum:
17.02.2015 12:33:39		 Views:
2030		 Rating:
     
Antwort:
  Ja
Thema:
Stundenzettel: Makro nimmt nicht alle SubFolder (Hauptordner auswählbar)

Hallo Zusammen,

ich habe folgendes Problem:

Mein Makro funktioniert nicht richtig:

Ich möchte alle "Stundenzettel" aus verschiedenen Unterordnern öffnen, bestimmte Zeilen kopieren und in meine Haupttabelle einfügen, wobei der Hauptordner per FolderPicker auswählbar ist.

Da ich Anfänger bin, habe ich das Makro aus anderen "zusammengebastelt".

Es funktioniert auch ganz gut. Nur ich verzweifele daran, dass er nicht alle Unterordner aussliest, sondern nur den ersten Unterordner.

Die Stundenzettel können sich in den auswählbaren Hauptordner oder auch in verschiedenen Unterordnern befinden.

Ich vermute, dass das für einen erfahrenen VB-Spezi ´ne Kleinigkeit ist.??

Für jede Hilfe bin ich dankbar, ich komme einfach nicht weiter.....

 

?
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
Option Explicit
 
Dim objFileSystemObject As Object
Dim objDateien As Object
Dim objWeitereDateien As Object
Dim objDatei As Object
Dim lngFirstFreeRow As Long
Dim wksAuswertsheet As Worksheet
Dim lngIndex As Long
Dim strOrdner As String
 
 
Sub Smiley1_Klicken()
 
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual 'automat.Berechnung ausschalten
 
Dateiname = Application.ActiveWorkbook.Name
 
Sheets("Tabelle1").Activate
Range(Cells(2, "A"), Cells(Rows.Count, "AC")).ClearContents
 
    
  With Application.FileDialog(msoFileDialogFolderPicker)
       .InitialFileName = ThisWorkbook.Path & "\"
       .Title = "Ordnerauswahl - nur Stundenzettel"
       .ButtonName = "Auswahl..."
       .InitialView = msoFileDialogViewList
       If .Show = -1 Then
          strOrdner = .SelectedItems(1)
          If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
         Else
         strOrdner = ""
        End If
   End With
   If strOrdner = "" Then MsgBox ("Kein Ordner gewählt!"), vbInformation
 
sprungziel:
 
'Objektverweise zuweisen
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objDateien = objFileSystemObject.GetFolder(strOrdner)
Set wksAuswertsheet = ThisWorkbook.Sheets("Tabelle1")
     
'-------------------------------------------------------------------------
 
For Each objDatei In objDateien.Files
If objDatei.Name Like "*Stunden*" And objDatei.Name Like "*.xls" Or objDatei.Name Like "*Std*" And objDatei.Name Like "*.xls" Then
 
'erste freie Zelle in der Zieldatei in Spalte A ermitteln
lngFirstFreeRow = wksAuswertsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
 
'Meldung in Statusbar anzeigen
Application.StatusBar = "Datei """ & objDatei.Name & """ wird ausgelesen!"
DoEvents
 
'Gefundene Datei unsichtbar öffnen
GetObject (objDatei)
 
 
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 in aktueller übertragen
wksAuswertsheet.Cells(lngFirstFreeRow, 3) = _
Workbooks(objDatei.Name).Sheets(1).Range("D4")
wksAuswertsheet.Cells(lngFirstFreeRow, 4) = _
Workbooks(objDatei.Name).Sheets(1).Range("E12")
wksAuswertsheet.Cells(lngFirstFreeRow, 5) = _
Workbooks(objDatei.Name).Sheets(1).Range("G47")
wksAuswertsheet.Cells(lngFirstFreeRow, 6) = _
Workbooks(objDatei.Name).Sheets(1).Range("C5")
wksAuswertsheet.Cells(lngFirstFreeRow, 7) = _
Workbooks(objDatei.Name).Sheets(1).Range("D9")
wksAuswertsheet.Cells(lngFirstFreeRow, 8) = _
Workbooks(objDatei.Name).Sheets(1).Range("E9")
wksAuswertsheet.Cells(lngFirstFreeRow, 9) = _
Workbooks(objDatei.Name).Sheets(1).Range("D10")
wksAuswertsheet.Cells(lngFirstFreeRow, 10) = _
Workbooks(objDatei.Name).Sheets(1).Range("E10")
wksAuswertsheet.Cells(lngFirstFreeRow, 11) = _
Workbooks(objDatei.Name).Sheets(1).Range("D11")
wksAuswertsheet.Cells(lngFirstFreeRow, 12) = _
Workbooks(objDatei.Name).Sheets(1).Range("E11")
wksAuswertsheet.Cells(lngFirstFreeRow, 13) = _
Workbooks(objDatei.Name).Sheets(1).Range("D4")
wksAuswertsheet.Cells(lngFirstFreeRow, 14) = _
Workbooks(objDatei.Name).Sheets(1).Range("E12")
wksAuswertsheet.Cells(lngFirstFreeRow, 15) = _
Workbooks(objDatei.Name).Sheets(1).Range("G47")
wksAuswertsheet.Cells(lngFirstFreeRow, 16) = _
Workbooks(objDatei.Name).Sheets(1).Range("K5")
wksAuswertsheet.Cells(lngFirstFreeRow, 17) = _
Workbooks(objDatei.Name).Sheets(1).Range("L9")
wksAuswertsheet.Cells(lngFirstFreeRow, 18) = _
Workbooks(objDatei.Name).Sheets(1).Range("M9")
wksAuswertsheet.Cells(lngFirstFreeRow, 19) = _
Workbooks(objDatei.Name).Sheets(1).Range("L10")
wksAuswertsheet.Cells(lngFirstFreeRow, 20) = _
Workbooks(objDatei.Name).Sheets(1).Range("M10")
wksAuswertsheet.Cells(lngFirstFreeRow, 21) = _
Workbooks(objDatei.Name).Sheets(1).Range("L11")
wksAuswertsheet.Cells(lngFirstFreeRow, 22) = _
Workbooks(objDatei.Name).Sheets(1).Range("M11")
wksAuswertsheet.Cells(lngFirstFreeRow, 23) = _
Workbooks(objDatei.Name).Sheets(1).Range("R9")
wksAuswertsheet.Cells(lngFirstFreeRow, 24) = _
Workbooks(objDatei.Name).Sheets(1).Range("S9")
wksAuswertsheet.Cells(lngFirstFreeRow, 25) = _
Workbooks(objDatei.Name).Sheets(1).Range("R10")
wksAuswertsheet.Cells(lngFirstFreeRow, 26) = _
Workbooks(objDatei.Name).Sheets(1).Range("S10")
wksAuswertsheet.Cells(lngFirstFreeRow, 27) = _
Workbooks(objDatei.Name).Sheets(1).Range("R11")
wksAuswertsheet.Cells(lngFirstFreeRow, 28) = _
Workbooks(objDatei.Name).Sheets(1).Range("S11")
wksAuswertsheet.Cells(lngFirstFreeRow, 29) = _
Workbooks(objDatei.Name).Sheets(1).Range("U33")
 
'HYPERLINK
wksAuswertsheet.Hyperlinks.Add Anchor:=wksAuswertsheet.Cells(lngFirstFreeRow, 1), _
Address:=strOrnder & objDatei.Name
 
'Geöffnete Datei wieder schließen ohne zu speichern
Workbooks(objDatei.Name).Close SaveChanges:=False
 
End If
Next
 
'Nächstes Verzeichnis abfragen
Dim SubFolder As Object
For Each SubFolder In objDateien.SubFolders
Set strOrdner = SubFolder
 
GoTo sprungziel
 
Next SubFolder
 
'-------------------------------------------------------------------------
 
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
  
 'Zuweisung wieder aufheben
Set objFileSystemObject = Nothing
Set objDateien = Nothing
Set wksAuswertsheet = Nothing
 
'Text aus Statusbar löschen
Application.StatusBar = ""
  
    ThisWorkbook.Save:  MsgBox "Fertig - Stundenzettel eingelesen", vbInformation, "Stundenzettel einlesen..."
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:
WYSIWYG-Editor, ctl00_Content_editor1



  • 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
Rot Stundenzettel: Makro nimmt nicht alle SubFolder (Hauptordner auswählbar)
 17.02.2015 12:33:39 Daniel
NotSolved
17.02.2015 19:37:13 MarkusK
Solved
17.02.2015 21:20:10 Daniel
NotSolved
18.02.2015 08:42:42 Daniel
Solved