Office: Ordner durchsuchen und Hyperlink ertsellen

Hallo,

ich habe folgendes Problem und zwar ich habe einen Ordner in dem 50 weitere Ordner sind und jeder von denen enthaelt weitere Unterordner mit Files. Und ich habe eine Excel-Tabelle in der die Nummern der Files stehen. Ich brauche ein Makro das die Nummer, die in der Excel eingetragen ist nimmt und diese in dem Ordnern sucht und wenn es die findet, dann einen Hyperlink zu diesem File herstellt.
Koennte mir da jemand helfen? Ich brauche ein Makro dafuer, da es sehr viele Files sind.

:)

 

HAllo

DAS habe ich verstanden !

Was sind das für Nummern ?

Da müsstest du auch etwas konkreter werden...

Wenn diese Unklarheiten beseitigt sind kann man mit Hyperlinks.add() die Links ratzfatz erstellen..

ransi

 

also die nummer lautet HS-1000000.prt
die HS- ist nur die interne Bezeichnung der Files und 1000000 ist die laufende Nummer. die nächste Datei ist dann z. B. 1000105 usw. und .prt ist die Dateiformat von Inventor 3-D Model.
es sieht dann so aus, dass ich im excel in der Spalte C ab der Zelle 2 die nummer stehen:
Zelle C2: HS-1000000
Zelle C3: HS-1000001
Zelle C4: HS-1000099
Zelle C5: HS-1002785
Zelle C6: HS-1046738
Zelle C7: leer, hier steht nichts
Zelle C8: wieder leer
Zelle C9: HS-1890672

usw. Also in der leeren Zellen kommt die Nummer dann irgendwann. Aber im Moment sind diese noch leer.
VBA muss dann die Nummer nehmen z.B. "HS-100000" und dann in den Ordnern suchen (z.B. C.\Projekt\.....) (in dem Projekt Ordner sind sher viele andere Ordner vorhanden und in einem von denen liegt diese Datei HS-1000000.prt) und wenn gefunden dann den Hyperlink herstellen, wenn nicht dann eine Msgbox: wurde nicht gefunden oder sowas.


Im Voraus besten Dank

 

Hallo Schattenläufer,

so?

' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub makeLink()
Dim objFiles() As Object
Dim lngRet As Long, lngIndex As Long
Dim vntRet As Variant
Dim rng As Range
Dim strPath As String, strFile As String
strPath = "E:\Forum" 'Stammverzeichnis - Anpassen!
lngRet = FileSearchINFO(objFiles, strPath, "HS*.prt", True)
If lngRet > 0 Then
With ActiveSheet 'oder With Sheets("Tabelle1")
For lngIndex = 0 To lngRet - 1
strFile = objFiles(lngIndex).Name
vntRet = Application.Match(Left(strFile, Len(strFile) - 4), .Columns(3), 0)
If IsNumeric(vntRet) Then
.Hyperlinks.Add Anchor:=.Cells(vntRet, 3), Address:=CStr(objFiles(lngIndex))
End If
Next
End With
End If
End Sub

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long

'# 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 GoTo ErrExit
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
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function





« Gruß Sepp »

 

Hallo,

vielen Dank.
Macro durchsucht das ganze aber stellt leider kein Hyperlink.
weiss ich aber nicht warum, ich habe es auf "watch" gesetzt und habe geschaut dass er zwar in den Ordner reingeht aber irgendwie die datei dann uebersieht.
Woran kann das liegen?!

 

Also das Problem hat sich erledigt da ich das Makro nicht laufen liess sondern immer in Debug modus gearbeitet habe. Und er sucht immer den kompletten Ordner durch.
Vielen Dank fuer die Hilfe !!!!!!!!!*Smilie *Smilie *Smilie *Smilie *Smilie *Smilie *Smilie *Smilie *Smilie *Smilie *Smilie *Smilie