Datenblätter zusammenfassen

Thomas · 2005-10-19T14:58:02+00:00

Hallo zusammen! Mir stellt sich folgendes Problem: Ich habe 10 Ordner (Regionen) mit jeweils mehreren Excel-Dateien (jeweils 1 pro Gemeinde), diese haben wiederum mehrere Mappen (jeweils 1 pro Zone). Jede Mappe ist ein standardisiertes und bereits ausgefülltes Aufnahmeblatt mit gewissen Kriterien. D.h. jedes Kriterium ist jeweils in der selben Zelle platziert (z.B. C3). Um die Daten effektiv auswerten zu können, möchte ich ein einziges Excel-Blatt, in dem alle Daten quasi als Rohdaten zusammengefasst werden. Gibt es eine Möglichkeit, das Ganze mit einer Formel oder einem schlauen Makro zu lösen? Ich bin jetzt mühsam am Makros schreiben, die individuell lauten müssen (Regions-, Gemeinde- und Zonennamen). Pro Zeile sollte eine Gemeinde erscheinen, in den Spalten sollten die dazugehörigen Kriterien sein. Beste Grüsse und vielen Dank für Eure Hilfe Thomas

Hallo Thomas,
hier mal eine erste Testversion.
Schau mal, wo's noch hapert.
fG
Rolf
Option Explicit
Dim WS As Worksheet
'Startprozedur


Sub start_GetValues()
'(C) Rolf Beißner 10.2005
Dim verz As String
verz = GetOrdner
ChDir verz
Application.ScreenUpdating = False
Set WS = ThisWorkbook.Sheets(1)
ShowFileList (verz)
End Sub

'Excel-Dateien öffnen


Sub ShowFileList(folderspec)
Dim exapp As Object, fs As Object, f As Object, fc As Object, fl As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each fl In fc
If fl.Type = "Microsoft Excel-Arbeitsblatt" Then
Set exapp = GetObject(folderspec & "\" & fl.Name)
Call daten_übernehmen(exapp)
Call schliessen(fl.Name)
End If
Next
End Sub

'Datenübernahme


Sub daten_übernehmen(qfile)
Dim zarr(), sarr()
Dim i%, n%, m%
Dim qsheet As Worksheet
Set qsheet = qfile.Sheets(1)
zarr = Array(3, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24)
sarr = Array(2, 4, 4, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 5, 5)
n = UBound(zarr)
m = WS.Cells(65536, 1).End(xlUp).Row + 1
Set qsheet = qfile.Sheets(1)
For i = 1 To n
WS.Cells(m, i) = qsheet.Cells(zarr(i), sarr(i))
Next
End Sub

'Schließprozedur


Sub schliessen(wind)
Windows(wind).Visible = True
Application.DisplayAlerts = False
Workbooks(wind).Close
End Sub

'Ordnerauswahl


Function GetOrdner(Optional ByVal def = "")
Dim objShell As Object, objfolder As Object
Set objShell = CreateObject("Shell.Application")
Set objfolder = objShell.BrowseForFolder(0, "Bitte einen Ordner wählen", 0, def)
If objfolder Is Nothing Then End
GetOrdner = objfolder.Self.Path
End Function

Hallo Thomas,
Mail ist angekommen, aber dem Screenshot kann ich nichts entnehmen.
Wir nehmen jetzt mal die möglicherweise kritischen Befehle raus,
und schauen, was passiert.
Das Verzeichnis "G:\Ortsbildschutz\Knonaueramt" sollte für
den Test nur wenige Dateien enthalten.
Der schrittweise Test (debuggen) geht so:
Du schaltest mit ALT+F11 in die Entwicklungsumgebung,
setzt den Cursor auf "start_copy_values()",
und drückst dann sukzessive F8.
Wenn du das Lokalfenster aktiviert hast (Ansicht -Lokalfenster),
kannst du während des Debuggens die Variablenentwicklung verfolgen.
hG
Rolf
Option Explicit
Dim WS As Worksheet
'Startprozedur


Sub start_copy_values()
'(C) Rolf Beißner 10.2005
Dim verz As String
'verz = GetOrdner
verz = "G:\Ortsbildschutz\Knonaueramt"
ChDir verz
'Application.ScreenUpdating = False
Set WS = ThisWorkbook.Sheets(1)
ShowFileList (verz)
End Sub

'Excel-Dateien öffnen


Sub ShowFileList(folderspec)
Dim exapp As Object, fs As Object, f As Object, fc As Object, fl As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each fl In fc
If fl.Type = "Microsoft Excel-Arbeitsblatt" Then
'Set exapp = GetObject(folderspec & "\" & fl.Name)
Set exapp = Workbooks.Open(folderspec & "\" & fl.Name)
Call daten_übernehmen(exapp)
Call schliessen(fl.Name)
End If
Next
End Sub

'Datenübernahme


Sub daten_übernehmen(qfile)
Dim zarr(), sarr()
Dim i%, n%, m%
Dim qsheet As Worksheet
zarr = Array(3, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24)
sarr = Array(2, 4, 4, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 5, 5)
n = UBound(zarr)
m = WS.Cells(65536, 1).End(xlUp).Row + 1
Set qsheet = qfile.Sheets(1)
For i = 1 To n
WS.Cells(m, i) = qsheet.Cells(zarr(i), sarr(i))
Next
End Sub

'Schließprozedur


Sub schliessen(wind)
Windows(wind).Visible = True
'Application.DisplayAlerts = False
Workbooks(wind).Close
End Sub

'Ordnerauswahl


Function GetOrdner(Optional ByVal def = "")
Dim objShell As Object, objfolder As Object
Set objShell = CreateObject("Shell.Application")
Set objfolder = objShell.BrowseForFolder(0, "Bitte einen Ordner wählen", 0, def)
If objfolder Is Nothing Then End
GetOrdner = objfolder.Self.Path
End Function

Forumthread: Datenblätter zusammenfassen

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Datenblätter zusammenfassen

Forumthread: Datenblätter zusammenfassen

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread