Clever-Excel-Forum

Hallo Leute, 

ich habe im Internet ein VBA Code gefunden der Ordnerstrukturen erstellt und Dokumente über Hyperlinks anzeigen lässt. Allerdings werden die Hyperlinks am ende des Pfades ausgegeben und ich kann diese nicht Filtern.
Wie lasse ich die Hyperlinks alle untereinander in z.B. Spalte 1 anzeigen?
Habe im Code rot markiert, wo ich denke dass ich den Befehl hinschreiben muss.



Code:

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 = Range("SuchOrdner") '=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 /hier denke ich muss gesgt werden dass die Hyperlinks in die erste Spalte sollen
    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


Mit freundlichen Grüßen 


Denkmalnach

Moin Denkmalnach!
Dann denk mal nach!
Du brauchst den Teil nach dem letzten Backslash.
In VBA kann man auch von rechts suchen: InstrRev()
Und Teil ist Mid()
Die Länge darfst Du großzügig wählen, nimm 9^9

?Mid("a\bc\d\efgh", InStrRev("a\bc\d\efgh", "\") + 1, 9^9)
efgh

Gruß Ralf

Danke für deine schnelle Antwort! Bin leider echt nur ganz Grundlegend mit VBA vertraut und bräuchte glaub ich nochmal einen Hinweis. So hab ich es jetzt versucht aber 
bekomme einen Fehler beim kompilieren.



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 = Range("SuchOrdner") '=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:="\'ist das der Backslash den du meinst?' \Mid("a\bc\d\efgh", InStrRev("a\bc\d\efgh", "\") + 1, 9^9)
  efgh
    'Hyperlinks ans ende setzen /hier denke ich muss gesgt werden dass die Hyperlinks in die erste Spalte sollen
    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

Hallöchen,

- was sagt denn die Aufzeichnung von Text in Spalten dazu?
- was willst Du mit efgh erreichen?

ich habs auch nicht genau verstanden und wollte deshalb nochmal nachfragen wie der code gemeint war. Habe auch nicht verstanden wieso a\bc\d\efgh so getrennt wurden und diese sind doch auch nicht definiert? Oder irre ich mich? 
Hab den Code halt nicht selber geschrieben und kann ihn nur halbwegs nachvollziehen. Aber irgendwie muss ich ja sagen können, dass er die Hyperlinks in der ersten Spalte anordnet oder nicht?

Gruß Denkmalnach