VBA Laufzeitfehler 1004

[Denkmalnach]

Moin Moin, 

ich habe im Internet ein VBA Programm gefunden, dass mir Ordner, Unterordner und Dateien mit Hyperlinks in Excel einpflegt. Bei kleineren Ordnern funktioniert das sehr gut, allerdings bekomme ich bei großen Ordnern einen Laufzeitfehler 1004. Ich habe im Anhang mal Bilder gepackt und würde mich wahnsinnig über Ideen freuen.

Schöne Woche 

MfG Denkmalnach

Der Code:

Option Explicit

Sub Hyperlinks()
Dim foundArr As Variant
Dim filePfad As String, fileExt As String, fileAge As Integer
Dim result As Long, i As Long
'Zu durchsuchender Pfad
'----------------------
'Anpassen
'filePfad = "C:\drivers\"
filePfad = "Dateipfad" '=K1

'------------------------
'Dateierweiterung
'Allenfalls für spezifische Dateien anpassen
fileExt = "*"
'------------------------
Application.ScreenUpdating = False
Application.StatusBar = "Searching for Files in folder :" & filePfad
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Clear
result = FileSearchINFO(foundArr, filePfad, "*." & fileExt, True)
Cells(2, 1) = "Pfad"
If result <> 0 Then
    For i = 0 To UBound(foundArr)
        Cells(i + 3, 1) = foundArr(i)
        Application.StatusBar = "Import Filename " & i & " of " & UBound(foundArr)
    Next
End If
'Spalte für Hyperlinks erstellen
Columns("A:A").Insert shift:=xlToRight
For i = 3 To Cells(Rows.Count, 2).End(xlUp).Row
    'Anwenderinfo
    Application.StatusBar = "Create Hyperlink " & i & " of " & UBound(foundArr)
    'Hyperlinks erstellen
    Cells(i, 1).FormulaLocal = "=hyperlink(""" & Cells(i, 2).Text & """;""" & Right(Cells(i, 2).Text, Len(Cells(i, 2).Text) - InStrRev(Cells(i, 2).Text, "\", -1)) & """)"
    'Aufteilen der gefundenen Dateien
    Cells(i, 2).TextToColumns Destination:=Cells(i, 2), DataType:=xlDelimited, Other:=True, OtherChar:="\"
    'Hyperlinks ans ende setzen
    Cells(i, Cells(i, Columns.Count).End(xlToLeft).Column).Formula = Cells(i, 1).Formula
Next i
'spalten bereinigen
Range("A1:A" & Cells(Rows.Count, 2).End(xlUp).Row).Delete shift:=xlToLeft
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "Import abgeschlossen", vbOKOnly, "File List"
Application.StatusBar = False
End Sub

Private Function FileSearchINFO(ByRef Files As Variant, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
        Optional ByVal SubFolders As Boolean = False) As Long
'by J.Ehrensberger
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error Resume Next
If InStr(1, FileName, ";") > 0 Then
    varFiles = Split(FileName, ";")
Else
    ReDim varFiles(0)
    varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
    If Not ffsoFile Is Nothing Then
        For intC = 0 To UBound(varFiles)
            If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
                If IsArray(Files) Then
                    ReDim Preserve Files(UBound(Files) + 1)
                Else
                    ReDim Files(0)
                End If
                Set Files(UBound(Files)) = ffsoFile
            End If
        Next
    End If
Next

If SubFolders = True Then
    For Each ffsoSubFolder In ffsoFolder.SubFolders
        Application.StatusBar = "Searching Files in Subfolder: " & ffsoSubFolder.Name
        FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
    Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
On Error GoTo 0
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function

---

Hyperlinks können maximal 255 Zeichen enthalten.

[schauan]

Hallöchen,

bei

allerdings bekomme ich bei großen Ordnern einen Laufzeitfehler 1004

wäre statt

Dim intC As Integer

oft

Dim intC As Long

besser

( Ich nehme an, die Ordner sind nicht größer sondern es sind mehr Daten drin
Wobei man pingelich sein kann und auch Ordnern physikalisch mehr Platz auf der Platte zugestehen, nur müsste man dann zum Vergleich auch wissen, ob in kleinen Ordnern vielleicht größere Dateien liegen ... )

[Gast 123]

Hallo

ein interessantes Programm, aus reiner Neugier habe ich es getestet, ziehe aber zum Auflisten von Orndnern meine Auflistung vor!
Da stehen Ordner und die darin befindlichen Dateien schön sauber untereinander statt nebeneinander. Die Übersicht gefällt mir besser!

Technische Info   -  auch für neugierige Kollegen!
Diese uralte Gurke, so um die ~1997 aus dem Internet herunterladen, ständig in Betrieb, ist meistens zeitlich schneller als FSO mit Array!
Eine uralte Excel 7/97 $Dir Version, wo ich jedesmal überrascht und amüsiert bin das sie immer noch schneller ist wie das moderne FSO.
Für meinen Ordner "Eigene Dateien" benötigt das neue Programm 40 Sekunden zum auflisten, meine alte Gurke schafft es in 27 Sekunden.

Eine Besonderheit hat meine Datei, aufgebaut aus 25 Jahren Excelerfahrung. Ich liste bei allen HTML Ordner nicht mehr den Inhalt auf!
Das kann man im Makro einstellen, falls es mal erforderlich ist. Und Dateifehler, Dateinamen mit Sonderzeichen, bekomme ich angezeigt!

mfg Gast 123

---

PS   den Ordnerpfad kann man in Zelle C1 eingeben.  Ich habe auch eine Version wo man den ordner über xlDialog auswählen kann.