Excel: Ordner durchsuchen und bestimmte Zellen als Ergebnis ausweisen

Guten Morgen,

ich stehe leider vor einem Problem, dass ich leider nur zur Hälfte durch Recherche hier im Forum lösen konnte und benötige daher ein paar Hinweise durch euch:

Problem
In einem Ordner liegen diverse Exceldateien. Die Dateinamen sind alle unterschiedlich benannt (Firmennamen). Inhaltlich ist jede Datei gleich aufgebaut, eine Sheet mit immer gleich bezeichneten Spalten. In den Dateien werden die Bestellungen (Produktname sowie einzelne Daten zu den Bestellungen) aufgelistet, es wird aber nicht mehr der Firmenname genannt. Die Dateien ändern sich, es kommen neue dazu und die bestehenden werden angepasst.

Um bei Rückfragen schnell zu sehen, welches Produkt bereits bei welchem Kunden gelistet ist, benötige ich eine Suchfunktion, die eine bestimmte Spalte (Produktname) in allen Dateien eines Ordners durchsucht und mir dann folgendes auswirft:

- Dateiname (weil Kundenname)
- Produktname (komplett, da Suche = xlPart)
- Zwei Zellen nach dem Produktnamen, aber nicht direkt die ganze Zeile
- Das ganze im Loop, die Suche darf nicht nach dem ersten Treffer enden, da mehrere Ergebnisse pro Kunde bzw. bei mehreren Kunden zu erwarten sind und ich alle benötige
- Optimal wäre die Anzeige in der gleichen Datei um diese direkt auszudrucken, optional auch als separate neue Datei

Mein Ansatz
Da ich nur sehr selten mit VBA Modulen zu tun hatte, habe ich mir anhand ähnlicher Probleme und Lösungen hier aus dem Forum folgendes Modul gebastelt.

Option Explicit
Option Compare Text

Const SuchPfad = "D:\Testordner"                 
Const SuchName = "*.xls*"                             

Const SuchSpalte = "D"                                    

Const TitelZeile = "FELD A, FELD B, FELD C, FELD D"        
Const StartZeile = 2                                  

Const Msg = "Fehler - Ordner nicht vorhanden!"  

Sub GetExternData()
    Dim Wkb As Workbook, Wks As Worksheet, WksHome As Worksheet
    Dim Fso As Object, File As Object, Found As Range, Search As String, NextLine As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    If Fso.FolderExists(SuchPfad) = False Then MsgBox Msg, vbExclamation, "Fehler":  Exit Sub  
   
    Search = InputBox("Bitte Suchbegriff eingeben:", "Suchen...")  
    
    If Search = "" Then Exit Sub  
    
    Application.ScreenUpdating = False
    
    Set WksHome = ThisWorkbook.Sheets(1)
    
    WksHome.Cells.ClearContents
    
    With WksHome.Range("A1:D1")  
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Value = Split(TitelZeile, ",")  
    End With
    
    NextLine = StartZeile
    
    For Each File In Fso.GetFolder(SuchPfad).Files
        If File.Name Like SuchName And Not File.Name Like ThisWorkbook.Name Then
            Set Wkb = Workbooks.Open(File.Path)
            
            For Each Wks In Wkb.Worksheets
                If Not Wks.Columns(SuchSpalte).Find(Search, LookIn:=xlValues, lookat:=xlPart) Is Nothing Then
                    With WksHome.Rows(NextLine)
                        .Columns("A") = ActiveCell  
                        .Columns("B") = File.Name  
                        .Columns("C") = Cells(ActiveCell.Row, ActiveCell.Column + 1)  
                        .Columns("D") = Cells(ActiveCell.Row, ActiveCell.Column + 2)  
                         NextLine = NextLine + 1
                    End With
                End If
            Next
            
            Wkb.Close False
        End If
    Next
    
    WksHome.Columns("A:D").AutoFit  
    
    Application.ScreenUpdating = True
End Sub

Damit bekomme ich in der offenen Datei die Überschriften und (fehlerhafte) Ergebnisse. Zudem endet die Abfrage nach dem ersten Treffer. Die Daten die angezeigt werden, stimmen nur bezüglich "File.Name". Mit "ActiveCell" und +1 bzw. +2 wollte ich die gefundene Zelle und die beiden Zellen danach anzeigen lassen, da wird mir aber teilweise (je nach Suchbegriff) die Spaltenüberschrift ausgeworfen.

Frage an euch
Wie bekomme ich mein Modul soweit, neben dem gefundenen Treffer auch die beiden Zellen danach auszuwerfen und nach dem ersten Treffer nicht aufzuhören mit der Suche ? Vielen Dank für eure Hilfe !

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

Content-ID: 298605

Url: https://administrator.de/forum/excel-ordner-durchsuchen-und-bestimmte-zellen-als-ergebnis-ausweisen-298605.html

Ausgedruckt am: 25.04.2025 um 09:04 Uhr

2 Kommentare

Neuester Kommentar

Hallo!

Da ActiveCell nix mit der Find-Zelle zu tun hat, wohl eher so:

    Dim FirstAddress As String	
    '.......  
            For Each Wks In Wkb.Worksheets
                Set Found = Wks.Columns(SuchSpalte).Find(Search, LookIn:=xlValues, LookAt:=xlPart)
                
                If Not Found Is Nothing Then
                    FirstAddress = Found.Address
                    Do
                        With WksHome.Rows(NextLine)
                            .Columns("A").Value = Found.Value  
                            .Columns("B").Value = File.Name  
                            .Columns("C").Value = Found.Offset(0, 1).Value  
                            .Columns("D").Value = Found.Offset(0, 2).Value  
                             NextLine = NextLine + 1
                        End With
                        Set Found = Wks.Columns(SuchSpalte).FindNext(Found)
                    Loop While Not Found Is Nothing And Found.Address <> FirstAddress
                End If
            Next

Gruß Dieter