VBA - Informationen aus mehreren Dateien auslesen

Hallo zusammen,

leider kenne ich mich mit VBA nicht so gut aus, daher meine Frage an alle Experte, ob es möglich ist Informationen aus einer Datei auszulesen, wenn eine bestimmte Bedingung erfüllt ist.

Ich hab hier einige Dateien, die alle exakt gleich aufgebaut sind, aus denen ich Daten in eine Excelliste auslesen bzw. übertrage will.
Meine Vorstellung wäre, dass beim Klick auf einen Button alle Dateien in einem Ordner durchsucht werden, ob ein bestimmt Zelle ausgefüllt ist (E2). Sollte dies der Fall sein sollen verschiedene Zellen (B2:B10) ausgelesen und ab Zeile 11 in die Liste übertragen werden. Dabei soll für jede ausgelesene Datei eine extra Zeile angelegt werden. Schön wäre auch eine vorherige Überprüfung, ob der übertrage Name bereits vorhanden ist, um Doppeleinträge zu vermeiden.

Gibt es eine Möglichkeit sowas über ein Makro zu regeln?
Vielen Dank im Voraus!

Greetz andyamo

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 148261

Url: https://administrator.de/forum/vba-informationen-aus-mehreren-dateien-auslesen-148261.html

Ausgedruckt am: 21.05.2025 um 05:05 Uhr

11 Kommentare

Neuester Kommentar

Sollte kein Problem sein....

Schau dir mal FileSystemObject an. Damit kannst du schonmal dein Ordner durchsuchen.

Gruß, Real-TTX

Hallo andyano und willkommen im Forum!

... auch wenn die Frage

Gibt es eine Möglichkeit sowas über ein Makro zu regeln?

durch Real-TTX eigentlich schon beantwortet ist

, doch noch eine Rückfrage:

Überprüfung, ob der übertrage Name bereits vorhanden ist

Was hätte ich mir denn unter diesem "Namen" vorzustellen?

Grüße
bastla

..OK, scheint so als wäre ich nicht präzise genug gewesen =)

Das ganze ist eine Art Fragebogen, in den oben Angaben zur Person eingetragen werden:

B2: Name, Vorname
B3: Alter
B4: ...

Anschließend kommt der Fragebogen, je nach Antworten wird dann teilw. ein X in E2 geschreiben.

Bei der Abfrage soll dann geprüft werden, ob das X in E2 geschrieben wurde. Falls ja sollen die Personenausgaben übertragen werden:

B2 in A11, B3 in B11, usw.
Sollte Zeile 11 bereits ausgefüllt sein natürlich entsprechend die daruntere Zeile....
Zudem die vorherige Überprüfung, ob der gleiche "Name, Vorname" schon eingetragen wurde.

So, hoffe diesmal war ich präziser =)

Hallo andyamo!

Viel besser

(obwohl Du noch nicht erklärt hast, was bei bereits vorhandenen Namen passieren soll) ...

Das folgende Makro ist aus der Zieltabelle in der Sammeldatei (die übrigens nicht im selben Ordner wie die einzelnen Fragebogen-Dateien liegen darf) zu starten (ob Du einen Button einfügst oder das Makro auf andere Art startest, ist für den Ablauf egal):

Sub Zusammenfassen()

Const sSourcePath = "D:\Datensammlung" 'Ordner der Fragebogendateien - bitte anpassen  

Set wbGes = ActiveWorkbook 'aktuelle Mappe und ...  
Set wsZiel = ActiveWorkbook.ActiveSheet '... aktuelle Tabelle zwischenspeichern  
Set fso = CreateObject("Scripting.FileSystemObject")  

Z = 11 'ab Zeile 11 in der Sammeltabelle eintragen  
sNamen = "#" 'Variable zum Sammeln der Namen vorbelegen  

Application.ScreenUpdating = False 'während der folgenden Aktionen Excel-Bildschirm "einfrieren"; diese Zeile kann auch auskommentiert / entfernt werden  
For Each oFile In fso.GetFolder(sSourcePath).Files 'alle Dateien des Fragebogenordners durchgehen  
    If LCase(fso.GetExtensionName(oFile.Name)) = "xls" Then 'nur .xls-Dateien bearbeiten; falls "xlsx" bitte anpassen; nur Kleinbuchstaben verwenden  
        Set wbQuellDatei = Application.Workbooks.Open(oFile.Path) 'Fragebogendatei öffnen  
        With ActiveWorkbook.Worksheets(1) 'Daten aus der ersten Tabelle der Fragebogendatei entnehmen  
            If .Range("E2").Value <> "" Then 'E2 nicht leer?  
                N = .Range("B2").Value 'Namen auslesen und ...  
                If InStr(sNamen, "#" & N & "#") = 0 Then '... prüfen, ob bereits verarbeitet  
                    .Range("B2:B10").Copy 'Daten kopieren und ...  
                    wsZiel.Cells(Z, "A").PasteSpecial Paste:=xlPasteAll, Transpose:=True '... einfügen (dabei die Spalte als Zeile behandeln)  
                    sNamen = sNamen & N & "#" 'Namen aus dem eben kopierten Datensatzes in die Liste aufnehmen  
                    Z = Z + 1 'Zeilennummer der Zieltabelle für das nächste Einfügen erhöhen  
                Else 'Name wurde bereits eingelesen - was nun?  
                    'Aktion, falls Name bereits eingelesen wurde  
                End If
            End If
        End With
        wbQuellDatei.Close 'Fragebogendatei schließen  
    End If
Next
Application.ScreenUpdating = True 'Excel-Bildschirmanzeige wieder "auftauen" ;-)  
wsZiel.Activate 'zur Sicherheit Zieltabelle aktivieren  
wbGes.Save 'Sammeldatei speichern  
MsgBox "Fertig."  
End Sub

Zu überlegen wäre noch, die Inhalte ab der Zeile 11 der Sammeltabelle vorweg zu löschen ...

Grüße
bastla

KLASSE! Vielen Dank für die schnelle und kompetente Hilfe!

2 Fragen hätte ich noch:
- Kann man die Aktion, die ausgeführt werden soll, wenn eine "Name, Vorname"-Kombi bereits existiert, so gestalten, dass die Daten verworfen werden und er die nächste Datei einliest?

- Derzeit werden beim mehrmaligen Einlesen vorhandene Zeilen überschrieben. Gibt es eine Möglichkeit, dass er nach der nächsten komplett leeren Zeile sucht und die Daten ab dort einfügt? Löschen bzw. Überschreiben vorhandener Zellen wäre schlecht, da in den Zeilen immer auch noch Informationen von Hand eingetragen werden sollen, die nicht eingelesen werden können.

Schonmal vielen Dank für deine Hilfe!

Hallo andyamo!

Derzeit werden zwar bereits bei Namensgleichheit die Daten verworfen - allerdings bezieht sich die Prüfung nur auf die aktuell einzulesenden Dateien. In Zukunft müssten dann ja wohl alle vorhandenen Namen ab Zelle A11 überprüft werden? (BTW: Eigentlich würde ich annehmen, dass eher die "alten" Daten verworfen bzw durch die neu Einzulesenden ersetzt werden sollten; wäre in diesem Zusammenhang ev auch ein Timestamp ein Thema?)

Das Anfügen an bereits vorhande Daten wird kein Problem sein.

Grüße
bastla

Zitat von @bastla:
In Zukunft müssten dann ja wohl alle vorhandenen Namen ab Zelle A11

Ja genau.

BTW: Eigentlich würde ich annehmen, dass eher die "alten" Daten verworfen bzw durch die neu Einzulesenden ersetzt werden sollten

Wenn ich es mir recht überlege hast du recht. Die bessere Lösung wäre, dass dann in der jeweiligen Zeile, in der der Name schon steht die Daten neu eingelesen werden.
Zur Veranschaulichung:

Muster, Max 25 7xxxx --> bisher in der Liste
Muster, Max 26 7xxx1 --> gleiche Zeile nach dem Einlesen einer Datei mit gleicher Namensangabe

Hoffe das verdeutlicht was ich meine. Überschreiben sollte kein Problem sein, da es nicht vorkommen wird, dass 2 Personen den gleichen Namen haben. Daher keine Gefahr von Datenverlust.
Nochmal vielen Dank!

Hallo andyamo!

Versuch es damit:

Sub Zusammenfassen()

Const sSourcePath = "D:\Datensammlung"  

Set wbGes = ActiveWorkbook
Set Ziel = ActiveWorkbook.ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")  

AbZeile = 11 '(ab Zeile 11 in der Sammeltabelle eintragen)  
Application.ScreenUpdating = False
For Each oFile In fso.GetFolder(sSourcePath).Files
    If LCase(fso.GetExtensionName(oFile.Name)) = "xls" Then 'nur .xls-Dateien bearbeiten  
        Set wbQuellDatei = Application.Workbooks.Open(oFile.Path)
        With ActiveWorkbook.Worksheets(1)
            If .Range("E2").Value <> "" Then 'E2 nicht leer?  
                N = LCase(.Range("B2").Value) 'Namen in Kleinbuchstaben auslesen und ...  
                Z = AbZeile '... ab der ersten Dateienzeile ...  
                '... in Spalte A suchen; falls nicht gefunden, erste Zeile ohne Eintrag in Spalte A verwenden  
                Do Until Ziel.Cells(Z, "A").Value = "" Or LCase(Ziel.Cells(Z, "A").Value) = N   
                    Z = Z + 1 'nächste Zeile untersuchen  
                Loop
                .Range("B2:B10").Copy 'kopieren und ...  
                Ziel.Cells(Z, "A").PasteSpecial Paste:=xlPasteAll, Transpose:=True '... einfügen (dabei die Spalte als Zeile behandeln)  
            End If
        End With
        wbQuellDatei.Close
    End If
Next 'Datei  
Application.ScreenUpdating = True
Ziel.Activate
'Gesamt-Datei speichern  
wbGes.Save
MsgBox "Fertig."  
End Sub

Ein Name wird nur bei (mit Ausnahme von Groß-/Kleinschreibung) identischer Schreibweise "wiedererkannt" ...

Grüße
bastla

Der Hammer! Vielen Dank funktioniert wunderbar!

Das war die gute Nachricht...hier die schlechte: Hab mich zwecks Übersichtlichkeit entschlossen die Liste anders zu gestalten und Zeilen und Spalten zu tauschen.
Folge: Transponde ist nicht mehr nötig.

Ich hab mal deinen Quellcode entsprechend angepasst ... er fügt die Daten auch an der richtigen Stelle ein, nur leider unter und nicht neben einander. Das Springen in die nächste Spalte (rechts), statt in die nächset Zeile bekomme ich nicht hin =(

Sub Zusammenfassen()

Const sSourcePath = "C:\Users\Andyamo\Desktop\Schlüsselpositionen\Bögen"  

Set wbGes = ActiveWorkbook
Set Ziel = ActiveWorkbook.ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")  

AbZeile = 6 '(ab Zeile 6 in der Sammeltabelle eintragen)  
Application.ScreenUpdating = False
For Each oFile In fso.GetFolder(sSourcePath).Files
    If LCase(fso.GetExtensionName(oFile.Name)) = "xls" Then 'nur .xls-Dateien bearbeiten  
        Set wbQuellDatei = Application.Workbooks.Open(oFile.Path)
        With ActiveWorkbook.Worksheets(1)
            If .Range("E24").Value <> "" Then 'E24 nicht leer?  
                N = LCase(.Range("C6").Value) 'Namen in Kleinbuchstaben auslesen und ...  
                Z = AbZeile '... ab der ersten Dateienzeile ...  
                '... in Spalte F suchen; falls nicht gefunden, erste Zeile ohne Eintrag in Spalte F verwenden  
                Do Until Ziel.Cells(Z, "F").Value = "" Or LCase(Ziel.Cells(Z, "F").Value) = N  
                    Z = Z + 1 'nächste Zeile untersuchen ##red|müsste nächste Spalte sein##  
                Loop
                .Range("C6:C9").Copy 'kopieren und ...  
                Ziel.Cells(Z, "F").PasteSpecial Paste:=xlValues, Transpose:=False '... einfügen (dabei die Spalte als Zeile behandeln)  
            End If
        End With
        wbQuellDatei.Close
    End If
Next 'Datei  
Application.ScreenUpdating = True
Ziel.Activate
'Gesamt-Datei speichern  
wbGes.Save
MsgBox "Fertig."  
End Sub

Hallo andyamo!

Soferne ich das richtig verstanden habe, sollen jetzt also alle Datensätze in Spalten stehen? Dann wäre das Suchen des Namens aber immer in der selben Zeile durchzuführen, nicht in der Spalte "F" ...

Die Umstellung solltest Du eigentlich selbst hinbekommen, wenn Du weißt, dass "Cells" als Parameter Zeile und Spalte erwartet und die Spalte auch numerisch angegeben werden kann - es ist also dafür genauso ein Zähler möglich, wie bisher Z für die Zeile ...

Grüße
bastla

P.S.: Wenn's gar nicht klappen sollte, helfe ich natürlich noch ein wenig ...

P.P.S.: Farb- ("##red|") oder zB auch Fett-Darstellung wird in einem "Code"-Block von der Forensoftware leider ignoriert (hast Du aber auch selbst schon gemerkt) ...