Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA: Datei suchen (inkl. Unterordner)

VBA: Datei suchen (inkl. Unterordner)
02.10.2012 11:11:05
Katharina
Hallo zusammen
Die Frage wurd hier schonmal so ähnlich gestellt, aber ich bekomme das ganze einfach nicht ans laufen.
https://www.herber.de/forum/archiv/1220to1224/t1221650.htm
Hier mein Problem:
In Spalte A stehen Identifikationsnummern, z.B. 123, 456, 567 etc
Nun möchte ich per VBA in einem bestimmten Verzeichnis inkl. Unterordner nach Excel Dateien suchen die zur jeweiligen ID gehören; die Excel Dateien fangen immer mit der ID an, also z.B. "123 ProduktABC.xls"; die Dateien befinden sich aber in verschiedenen Unterordnern (z.B. "G:\Produkte\2012\", "G:\Produkte\2011\" etc)
Wenn ich die Datei gefunden habe, soll mir das Makro in die Spalte daneben den Pfad, bzw. den Hyperlink zur Datei schreiben.
Hier habe ich ein Beispiel gefunden was etwas in der Art macht, aber wie schon obern erwähnt schaffe ich es einfach nicht, das Ganze für meine Bedürfnisse zu modifizieren:
http://hajo-excel.de/2007_hinweise.htm
Wäre super, wenn jemand helfen könnte!
Gruss
Katharina

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA: Datei suchen (inkl. Unterordner)
02.10.2012 11:50:51
Tino
Hallo,
hier mal eine Variante.
Eventuell die Tabelle und den Pfad anpassen.
Bin davon ausgegangen, dass die ID ab A2 aufgelistet sind und in A1 die Überschrift steht.
Ergebnis wird als Funktion (Hyperlink) in Spalte B geschrieben.
kommt als Code in Modul1
Option Explicit 
 
Sub Start() 
Dim strFolder$, ArFileFilter() 
Dim nCount&, lngFileCount& 
Dim ArrayData(), ArrayFile(), sFile$ 
  
strFolder = "G:\VBA" 'Ordner angeben 
 
With Tabelle1 'Tabelle anpassen 
     
   .Range("B2", .Cells(.Rows.Count, 2)).Clear 'Daten Spalte B löschen 
    nCount = .Cells(.Rows.Count, 1).End(xlUp).Row 
    If nCount < 2 Then Exit Sub 'keine Daten in Tabelle 
    ArrayData = .Range("A2", .Cells(nCount, 1)) 
    strFolder = IIf(Right$(strFolder, 1) = "\", strFolder, strFolder & "\") 
    For nCount = 1 To Ubound(ArrayData) 
        If ArrayData(nCount, 1) <> "" Then 
            ArFileFilter = Array(ArrayData(nCount, 1) & "*.*") 'Filter für die Suche 
            'Suchen mit Unterordner sonst SubFolder = False 
            FindFiles ArrayFile, strFolder, lngFileCount, ArFileFilter, True 
        End If 
        If lngFileCount > 0 Then 
            'nur erste gefundene Datei Listen 
            sFile = ArrayFile(0) 
            'Hyperlink erstellen 
            ArrayData(nCount, 1) = _
                "=HYPERLINK(""" & sFile & """,""" & Right$(sFile, Len(sFile) - InStrRev(sFile, "\")) & """)" 
            lngFileCount = 0 
        Else 
            ArrayData(nCount, 1) = "nix gefuden" 
        End If 
    Next nCount 
 
    .Range("B2").Resize(Ubound(ArrayData), 1).FormulaR1C1 = ArrayData 
 
End With 
Erase ArrayData 
End Sub 
 
 
 
  
 
kommt als Code in Modul2
Option Explicit 
'Teile des Originalcode von Nepumuk. *********************************************************** 
  
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    lpFindFileData As WIN32_FIND_DATA) As Long 
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    lpFindFileData As WIN32_FIND_DATA) As Long 
Private Declare Function FindClose Lib "kernel32" ( _
    ByVal hFindFile As Long) As Long 
  
Private Const INVALID_HANDLE_VALUE = -1& 
Private Const MAX_PATH = 260& 
  
Private Type FILETIME 
    dwLowDateTime As Long 
    dwHighDateTime As Long 
End Type 
  
Private Enum FILE_ATTRIBUTE 
    FILE_ATTRIBUTE_READONLY = &H1 
    FILE_ATTRIBUTE_HIDDEN = &H2 
    FILE_ATTRIBUTE_SYSTEM = &H4 
    FILE_ATTRIBUTE_DIRECTORY = &H10 
    FILE_ATTRIBUTE_ARCHIVE = &H20 
    FILE_ATTRIBUTE_NORMAL = &H80 
    FILE_ATTRIBUTE_TEMPORARY = &H100 
End Enum 
  
Private Type WIN32_FIND_DATA 
    dwFileAttributes As Long 
    ftCreationTime As FILETIME 
    ftLastAccessTime As FILETIME 
    ftLastWriteTime As FILETIME 
    nFileSizeHigh As Long 
    nFileSizeLow As Long 
    dwReserved0 As Long 
    dwReserved1 As Long 
    cFileName As String * MAX_PATH 
    cAlternate As String * 14 
End Type 
  
  
Sub FindFiles(ArrayData(), ByVal strFolderPath As String, _
        ByRef lngFileCount As Long, ArFileFilter, Optional SubFolder As Boolean = True) 
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String 
      
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD) 
      
    If lngSearch <> INVALID_HANDLE_VALUE Then 
        GetFilesInFolder ArrayData, strFolderPath, lngFileCount, ArFileFilter 
        Do 
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then 
                strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1) 
                If SubFolder = False Then Exit Sub 'ohne Unterordner 
                If (strDirName <> ".") And (strDirName <> "..") Then _
                    FindFiles ArrayData, strFolderPath & strDirName & "\", lngFileCount, ArFileFilter 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
End Sub 
  
Sub GetFilesInFolder(ArrayData(), ByVal strFolderPath As String, _
        ByRef lngFileCount As Long, ArFileFilter) 
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String 
Dim FileFilter 
  
For Each FileFilter In ArFileFilter 
    lngSearch = FindFirstFile(strFolderPath & FileFilter, WFD) 
    If lngSearch <> INVALID_HANDLE_VALUE Then 
        Do 
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> _
                FILE_ATTRIBUTE_DIRECTORY Then 
                strFileName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1) 
                Redim Preserve ArrayData(lngFileCount) 
                ArrayData(lngFileCount) = strFolderPath & strFileName 'auflisten in Zelle 
                lngFileCount = lngFileCount + 1 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
Next 
End Sub 
 
Gruß Tino

Anzeige
AW: VBA: Datei suchen (inkl. Unterordner)
02.10.2012 12:08:00
Katharina
Funktinoiert super! Vielen Dank!
Noch eine kleine Bitte: Kann ich auch noch in die Zelle daneben den kompletten Pfad schreiben, also ohne Hyperlink?

AW: VBA: Datei suchen (inkl. Unterordner)
02.10.2012 12:28:59
Tino
Hallo,
ersetze den Code im Modul1 durch diesen.
kommt als Code in Modul1
Option Explicit 
 
Sub Start() 
Dim strFolder$, ArFileFilter() 
Dim nCount&, lngFileCount& 
Dim ArrayData(), ArrayFile(), sFile$ 
  
strFolder = "G:\VBA" 'Ordner angeben 
 
With Tabelle1 'Tabelle anpassen 
     
   .Range("B2", .Cells(.Rows.Count, 3)).Clear 'Daten Spalte B u. C löschen 
    nCount = .Cells(.Rows.Count, 1).End(xlUp).Row 
    If nCount < 2 Then Exit Sub 'keine Daten in Tabelle 
    ArrayData = .Range("A2", .Cells(nCount, 1)).Resize(, 2) 
    strFolder = IIf(Right$(strFolder, 1) = "\", strFolder, strFolder & "\") 
    For nCount = 1 To Ubound(ArrayData) 
        If ArrayData(nCount, 1) <> "" Then 
            ArFileFilter = Array(ArrayData(nCount, 1) & "*.*") 'Filter für die Suche 
            'Suchen mit Unterordner sonst SubFolder = False 
            FindFiles ArrayFile, strFolder, lngFileCount, ArFileFilter, True 
        End If 
        If lngFileCount > 0 Then 
            'nur erste gefundene Datei Listen 
            sFile = ArrayFile(0) 
            'Hyperlink erstellen 
            ArrayData(nCount, 1) = _
                "=HYPERLINK(""" & sFile & """,""" & Right$(sFile, Len(sFile) - InStrRev(sFile, "\")) & """)" 
            'kompletter Pfad 
            ArrayData(nCount, 2) = sFile 
            lngFileCount = 0 
        Else 
            ArrayData(nCount, 1) = "nix gefuden" 
        End If 
    Next nCount 
 
    .Range("B2").Resize(Ubound(ArrayData), 2).FormulaR1C1 = ArrayData 
 
End With 
Erase ArrayData 
End Sub 
 
 
 
  
 
Gruß Tino

Anzeige
gelöst: VBA: Datei suchen (inkl. Unterordner)
02.10.2012 14:09:40
Katharina
Meeeega! Vielen Dank!

AW: VBA: Datei suchen (inkl. Unterordner)
02.10.2012 15:15:41
Katharina
Hallo Tino
Ich bekomme in meiner Datei nun komischerweise die Fehlermeldung: Laufzeitfehler '13': Typen unverträglich
Hat das mit dem Format von Spalte A zu tun?

AW: VBA: Datei suchen (inkl. Unterordner)
02.10.2012 15:22:40
Katharina
Bei dieser Zeile bleibt es hängen:
ArrayData = .Range("A2", .Cells(nCount, 1)).Resize(, 2)

AW: VBA: Datei suchen (inkl. Unterordner)
02.10.2012 23:00:41
Tino
Hallo,
wenn ich wüsste. was du geändert hast?!
Gruß Tino

AW: VBA: Datei suchen (inkl. Unterordner)
03.10.2012 08:33:01
Katharina
Hallo Tino
Der Code klappt es wunderbar in einem ganz neuen Excel (Sheet heisst ja dann automatisch Tabelle1), Ordnerpfad habe ich angepasst.
Dann habe ich versucht den in ein bestehendes Excel einzubauen. Dafür habe ich den Ordnerpfad wieder entsprechend angepasst und Tabelle1 durch Sheets(„Inventory“) ersetzt; im Excel befinden sich noch weitere sheets.
Jetzt funktioniert das Makro allerdings nicht mehr und ich bekomme die Fehlermeldung „Laufzeitfehler 13, Typen unverträglich“
Gruss
K

Anzeige
AW: VBA: Datei suchen (inkl. Unterordner)
03.10.2012 08:44:31
Tino
Hallo,
kannst du die Datei hochladen?
Gruß Tino

AW: VBA: Datei suchen (inkl. Unterordner)
03.10.2012 08:56:42
Katharina
Hallo Tino
Hier die (reduzierte) Datei:
https://www.herber.de/bbs/user/81966.xls
Normal hat die Datei noch ein paar sheets mehr, die kann ich aber nicht alle hochladen.
Gruss
K

AW: VBA: Datei suchen (inkl. Unterordner)
03.10.2012 09:37:32
Tino
Hallo,
ok versuch mal und mach aus der Zeile
ArrayData = .Range("A2", .Cells(nCount, 1)).Resize(, 2)

diese (.Value2 dazuschreiben)
ArrayData = .Range("A2", .Cells(nCount, 1)).Resize(, 2).value2

Und die Zeile
With ActiveWorkbook.Worksheets("P&L")

würde ich so abändern
With ThisWorkbook.Worksheets("P&L")
Gruß Tino

Anzeige
AW: VBA: Datei suchen (inkl. Unterordner)
03.10.2012 09:43:31
Katharina
FUNKTIONIERT!!!! Du bist mein held! Ich bin immer wieder erstaunt, was so alles machbar ist!
Was war denn das Problem?

AW: VBA: Datei suchen (inkl. Unterordner)
03.10.2012 09:52:31
Tino
Hallo,
der Datenbereich konnte nicht als Array dargestellt werden.
Warum kann ich auf schnelle auch nicht feststellen!
Gruß Tino

AW: VBA: Datei suchen (inkl. Unterordner)
03.10.2012 09:59:25
Katharina
FUNKTIONIERT!!!! Du bist mein held! Ich bin immer wieder erstaunt, was so alles machbar ist!
Was war denn das Problem?

8 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige