Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
368to372
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
368to372
368to372
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Werte aus mehreren geschl. Dateien auflisten

Werte aus mehreren geschl. Dateien auflisten
23.01.2004 20:17:04
Michaela
Hallo,
ich möchte aus allen Dateien mit dem Namen Report*.xls (anstelle des Sternchen steht immer der name einer Abteilung z.B: Report_FiBu.xls oder Report_IT.xls..) die sich in versch. UnterVerzeichnissen (zB. S:\Reports\FiBu\Report_FiBu.xls oder S:\Reports\IT\Report_IT.xls) unterhalb des Stammverzeichnisses S:\Reports\ befinden, Werte in eine GesamtDatei zusammenkopieren.
Die Dateien Report*.xls haben alle die gleiche erste Tabelle in der sich die zu kopierenden Daten befinden. Es soll aus jeder Datei aus der ersten Tabelle die Zelle D3, D17 und der Zellbereich B23:F27 mit den darunterliegenden Werten (falls vorhanden) kopiert werden.
Die Daten sollen alle in der ZielDatei nacheinander aufgelistet werden.
Zelle D3 aus der ersten Datei nach A3 in der Zieldatei
Zelle D17 aus der ersten Datei nach B3 in der ZielDatei
Zellbereich B23:B27 mit den darunterliegenden Werten nach D3:H3 der ZielDatei und darunterliegende Werte bis z.B. D5:H5
--
Zelle D3 aus der zweiten Datei nach A6 in der Zieldatei
Zelle D17 aus der zweiten Datei nach B6 in der ZielDatei
Zellbereich B23:B27 mit den darunterliegenden Werten nach D6:H6 der ZielDatei ZielDatei und darunterliegende Werte bis z.B. D10:H10
-- usw.
Ich könnte zu meiner Erklärung noch eine Datei als Beispiel hochladen oder zusenden.
Ich habe nur Grundkenntnisse in VBA und konnte daher die VBA-Codes aus den Archivbeiträgen nicht für meine Anforderungen anpssen.
Kann mir vielleicht jemand mit seinen VBA-Kenntnissen hier eine Lösung basteln?
Wäre echt Klasse!
Danke, Mcihaela

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Werte aus mehreren geschl. Dateien auflisten
23.01.2004 20:29:08
Michael
Sende mal bitte die Tabelle. Sollte möglich sein
mloegering@eplus-online.de
Probier mal...
23.01.2004 21:08:11
Ramses
Hallo
ohne es testen zu können, weil mir die Dateien fehlen, probier mal das:



Option Explicit

Sub Read_All_Files_and_Datas()
Dim As Long, totFiles As Long, RowCounter As Long
Dim geffile As String, dname As String
Dim Suchpfad As String, Suchbegriff As String, Dateiform As String
Dim tmpPfad As String, tmpName As String, tmpFile As String
Dim curWB As Workbook, datWB As Workbook, tarWKS As Worksheet
Dim oldStatus As Variant
Dim myR1 As String, myR2 As String, myR3 As String
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
Dateiform = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.xls")
If Dateiform = "" Then Exit Sub
Application.ScreenUpdating = True 'zur definitiven Ausführung auf False setzen
oldStatus = Application.StatusBar
RowCounter = 1
'Variablen setzen
Set curWB = Workbooks(ThisWorkbook.Name)
Set tarWKS = Worksheets("Tabelle1")
'zu kopierende Bereiche definieren
'Tabelle1 mit dem Namen der entsprechenden Tabelle ersezten
myR1 = "Tabelle1'!R3C3"
myR2 = "Tabelle1'!R17C4"
myR3 = "Tabelle1'!R23C2:R27C6"
'Dateisuche starten
With Application.FileSearch
    .LookIn = Suchpfad
    .SearchSubFolders = True
    .Filename = Dateiform
    'Wenn gefunden,..
    'Schleifenauswertung beginnen
    If .Execute() > 0 Then
        totFiles = .FoundFiles.Count
        Application.StatusBar = "Total " & totFiles & " gefunden"
        For i = 1 To .FoundFiles.Count
            geffile = .FoundFiles(i)
            'Namen und String zusammensetzen
            tmpName = Right(geffile, Len(geffile) - InStrRev(geffile, "\", -1))
            tmpPfad = Left(geffile, Len(geffile) - Len(tmpName))
            tmpFile = tmpPfad & "[" & tmpName & "]"
            If UCase(Left(geffile, 6)) = "REPORT" Then
                'In Tabelle eintragen
                curWB.tarWKS.Cells(RowCounter, 1) = Application.ExecuteExcel4Macro(tmpFile & myR1)
                curWB.tarWKS.Cells(RowCounter, 2) = Application.ExecuteExcel4Macro(tmpFile & myR2)
                curWB.tarWKS.Cells(RowCounter, 3) = Application.ExecuteExcel4Macro(tmpFile & myR3)
                RowCounter = RowCounter + 3
            End If
        Next i
    End If
End With
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
End Sub

     Code eingefügt mit Syntaxhighlighter 2.5


Gruss Rainer
Anzeige
AW: Probier mal...
23.01.2004 21:48:27
Michaela
Hallo Rainer,
ich hab´s versucht. Ich bekomme keine Fehlermeldung, habe aber auch keine Daten in meine Datei kopiert bekommen.
Ich habe dir die Datei hochgeladen evtl. kannst du es dir nochmals ansehen?
https://www.herber.de/bbs/user/3180.xls
Die Tabelle 'Summary' ist in jeder Datei das erste Tabellenblatt aus dem die Daten kopiert werden sollen.
Die Tabelle 'Gesamt_report' befindet sich in der ZielDatei in der alle Daten zusammenkopiert werden sollen.
P.S. Echt irre wie schnell du das Makro erstellt oder angepasst hast.
Vielen Dank schon mal,
Michaela
Anzeige
Das sollte laufen...
23.01.2004 22:45:00
Ramses
Hallo
zumindest mit deiner Beispieldatei kriege ich alle Daten.
Das Problem ist allerdings, dass der einzulesende Bereich hier bis Zeile 39 geht, in der Frage aber nur bis 27.
Wenn du nur die Daten brauchst, ändere die Zahl 39 in der 3. Schleife in 27


Option Explicit

Sub Read_All_Files_and_Datas()
Dim As Long, totFiles As Long
Dim ColCounter As Integer, RowCounter As Long
Dim As Integer, k As Integer
Dim geffile As String, dname As String
Dim Suchpfad As String, Suchbegriff As String, Dateiform As String
Dim tmpPfad As String, tmpName As String, tmpFile As String
Dim curWB As Workbook, datWB As Workbook, tarWKS As Worksheet
Dim oldStatus As Variant
Dim myR1 As String, myR2 As String, myR3 As String
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", "D:") 'Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
Dateiform = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.xls")
If Dateiform = "" Then Exit Sub
Application.ScreenUpdating = True 'zur definitiven Ausführung auf False setzen
oldStatus = Application.StatusBar
RowCounter = 1
ColCounter = 2
'Variablen setzen
Set curWB = Workbooks(ThisWorkbook.Name)
Set tarWKS = curWB.Worksheets("Tabelle1")
'zu kopierende Bereiche definieren
'Tabelle1 mit dem Namen der entsprechenden Tabelle ersezten
myR1 = "Summary'!R3C2"
myR2 = "Summary'!R17C4"
'Datumsformat in Spalte D zuweisen
Columns(4).NumberFormat = "m/d/yyyy"
'Dateisuche starten
With Application.FileSearch
    .LookIn = Suchpfad
    .SearchSubFolders = False
    .Filename = Dateiform
    'Wenn gefunden,..
    'Schleifenauswertung beginnen
    If .Execute() > 0 Then
        totFiles = .FoundFiles.Count
        Application.StatusBar = "Total " & totFiles & " gefunden"
        For i = 1 To .FoundFiles.Count
            geffile = .FoundFiles(i)
            'Namen und String zusammensetzen
            tmpName = Right(geffile, Len(geffile) - InStrRev(geffile, "\", -1))
            tmpPfad = Left(geffile, Len(geffile) - Len(tmpName))
            tmpFile = "'" & tmpPfad & "[" & tmpName & "]"
            If UCase(Left(Right(geffile, Len(geffile) - 3), 6)) = "REPORT" Then
                'In Tabelle eintragen
                tarWKS.Cells(RowCounter, 1) = Application.ExecuteExcel4Macro(tmpFile & myR1)
                tarWKS.Cells(RowCounter, 2) = Application.ExecuteExcel4Macro(tmpFile & myR2)
                tarWKS.Cells(RowCounter, 2).NumberFormat = "0.00%"
                'Zwei neue Schleifen um die einzelnen zellen in
                'den Zieldateien auszulesen
                For k = 23 To 39
                    For n = ColCounter To 6
                        myR3 = "Summary'!R" & k & "C" & n & ":R" & k & "C" & n
                        tarWKS.Cells(RowCounter, n + 1) = Application.ExecuteExcel4Macro(tmpFile & myR3)
                    Next n
                    RowCounter = RowCounter + 1
                Next k
                RowCounter = RowCounter + 1
            End If
        Next i
    End If
End With
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
End Sub

     Code eingefügt mit Syntaxhighlighter 2.5


Gruss Rainer
Anzeige
AW: Das sollte laufen...
23.01.2004 22:55:54
Michaela
Vielen Dank schon mal - ich kann das Makro erst morgen testen, da ich jetzt zum Zug muss.
Aber auf jeden Fall vielen, vielen Dank für so viel arbeit!
Michaela
Merci :-)) Geschlossen. o.T.
23.01.2004 23:02:47
Ramses
...

317 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige