Guten Tag,

ich hab mal versucht die Kritikpunkte zu berücksichtigen und hab den Code ein bisschen unterteilt. Leider komm ich im moment nicht weiter und hab das Gefühl ich hab es völlig falsch gemacht. 

 

Option Explicit

Sub BilderHyperlink()
  Dim strSelectedPath As String
  Dim xFDObject As FileDialog
  
'Ordner Auswählen
  Set xFDObject = Application.FileDialog(msoFileDialogFolderPicker)
With xFDObject
    .Title = "Bitte den Ordner mit den Bildern wählen:"
    .InitialFileName = Application.ActiveWorkbook.Path
    .Show
    .AllowMultiSelect = False
End With
  
'Nur wenn ein Ordner nicht angewählt wurde
If xFDObject.SelectedItems.Count > 0 Then
    strSelectedPath = xFDObject.SelectedItems.Item(1)
Else
    MsgBox "Keinen Ordner Ausgewählt", vbInformation Or vbOKOnly, "/ Information"
    Exit Sub
End If
   
'Sammlung erstellen
  Dim colFiles As VBA.Collection
  If SearchFiles(strSelectedPath, colFiles) = 0 Then
    Call MsgBox("Keine Treffer.", vbExclamation)
    Exit Sub
  End If
   
  Dim vntFullFilename As Variant
  For Each vntFullFilename In colFiles
    Call HandleFile(CStr(vntFullFilename))
  Next
      
'Kriterien Auswählen
Dim XRgName As Range
Dim XRgKurzbezeichnung As Range
Dim XRgBezeichnung As Range
   
'Hier wird die Bezeichnung ausgewählt und der Hyperlink und das Bild hinterlegt
Set XRgBezeichnung = Application.InputBox("Bitte den Bereich für die Bilder auswählen:", "Bitte die Spalte wählen", Type:=8)
If XRgBezeichnung Is Nothing Then Exit Sub
 
'Hier wird die Kurzbezeichnung ausgewählt
Set XRgKurzbezeichnung = Application.InputBox("Bitte den Bereich mit der Kurzbeschreibung auswählen:", "Bitte die Spalte wählen", Type:=8)
If XRgKurzbezeichnung Is Nothing Then Exit Sub
 
'Hier wird der Name ausgewählt
Set XRgName = Application.InputBox("Bitte den Bereich mit dem Namen wählen:", "Bitte die Spalte anwählen", Type:=8)
If XRgName Is Nothing Then Exit Sub
  
'Kriterien übergeben
Dim SearchTerm1 As String
Dim cy As Long

SearchTerm1 = NormalizeName(cy, XRgName, XRgKurzbezeichnung, XRgBezeichnung, SearchTerm1)

' Lösche alle Kommentare und Hyperlinks im ausgewählten Bereich
For cy = 1 To XRgBezeichnung.Count
    If XRgBezeichnung(cy, 1).Value2 = "" Then Exit For
    If Not XRgBezeichnung(cy, 1).Comment Is Nothing Then XRgBezeichnung(cy, 1).Comment.Delete
    If Not XRgBezeichnung(cy, 1).Hyperlinks Is Nothing Then XRgBezeichnung(cy, 1).Hyperlinks.Delete
       
       ' Funktion Kommentare und Hyperlinks hinterlegen
       Dim Filename As String
       CommentHyperlink SearchTerm1, Filename
    
Next

End Sub

Private Sub HandleFile(Optional FullFilename As String)
    
    'Thumbs werden aus der Abfrage entfernt
   
    Dim CheckFile As Boolean
    CheckFile = Right$(FullFilename, Len("thumbs.dp")) = "thumbs.dp"
    
    If CheckFile = True Then
        ' Ignoriere die Datei thumbs
        Exit Sub
    Else
        
        Call NormalizeFileName(FullFilename)
    End If
        
End Sub

'Dateinamen anpassen
Function NormalizeFileName(ByVal Filename As String) As String
    ' Entferne Leerzeichen am Anfang und Ende des Dateinamens
    Filename = Trim(Filename)

   ' Entferne Sonderzeichen aus dem Dateinamen
Dim specialChars() As String
specialChars = Split("!@#$%^&*()+=-[]{}|\;:'""<>,.?/~`", "")

Dim i As Integer
For i = 0 To UBound(specialChars)
    Filename = Replace(Filename, specialChars(i), "")
Next i

' Vereinheitliche die Groß- und Kleinschreibung des Dateinamens
Filename = LCase(Filename)

' Rückgabe des normalisierten Dateinamens
NormalizeFileName = Filename

End Function

'Kriterien anpassen
Function NormalizeName(ByVal cy As Integer, XRgName As Range, XRgKurzbezeichnung As Range, XRgBezeichnung As Range, ByRef SearchTerm1 As String) As String
    Dim specialChars() As Variant
    Dim i As Integer

    SearchTerm1 = Trim(SearchTerm1)

    specialChars = Array("!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "+", "=", "-", "[", "]", "{", "}", "|", "\", ";", ":", """", "<", ">", ",", ".", "?", "/", "~", "`")

    For i = LBound(specialChars) To UBound(specialChars)
        SearchTerm1 = Replace(SearchTerm1, specialChars(i), "")
    Next i

    SearchTerm1 = LCase(SearchTerm1)

    NormalizeName = SearchTerm1
End Function

Private Function CheckFile(FullFilename As String) As Boolean
   
  ' TODO: implement filter logic
  CheckFile = Right$(FullFilename, 4) = ".png"
   
End Function
 
Function CommentHyperlink(SearchTerm1 As String, Filename As String) As Boolean
    Dim file As Object
    Dim XRgBezeichnung As Range
    Dim cy As Integer
    Dim cmt As Comment

    Filename = NormalizeFileName(Filename)

    ' Setze den Dateipfad
    'Set file = CreateObject("Scripting.FileSystemObject").GetFile(Filename)

    ' Überprüfe, ob der Suchbegriff mit dem Dateinamen übereinstimmt
    If SearchTerm1 = Filename Then
        ' Setze den Hyperlink in die Zelle
        ActiveSheet.Hyperlinks.Add XRgBezeichnung(cy, 1), Address:=file.Path

        ' Setze den Kommentar für die Zelle
        Set cmt = XRgBezeichnung(cy, 1).AddComment
        With cmt
            .Shape.Fill.UserPicture file.Path
            .Shape.Height = 260
            .Shape.Width = 520
            .Shape.LockAspectRatio = msoFalse
        End With

        CommentHyperlink = True
    Else
        MsgBox "Die Datei: " & file.Name & " kann nicht zugeordnet werden. Auf korrekten Dateinamen prüfen!", vbCritical Or vbOKOnly, "/ Problem"
        CommentHyperlink = False
    End If
End Function
 
Private Function SearchFiles(Path As String, FoundFiles As VBA.Collection) As Long
  
  'Alle Unterordner durchlaufen
  
  If FoundFiles Is Nothing Then
    Set FoundFiles = New VBA.Collection
  End If
   
  Dim strPath As String
  Dim strFilename As String
   
  strPath = IIf(Right$(Path, 1) <> "\", Path & "\", Path)
   
  On Error GoTo ErrHandler
  strFilename = Dir$(strPath, vbDirectory)
  On Error GoTo 0
   
  Dim fileAttr As VbFileAttribute
  Dim colDirectories As VBA.Collection
  Set colDirectories = New VBA.Collection
   
  Do While strFilename <> vbNullString
     
    On Error GoTo ErrHandler
    fileAttr = -1
    fileAttr = GetAttr(strPath & strFilename)
    On Error GoTo 0
     
    If (fileAttr And vbDirectory) = vbDirectory And Not (fileAttr And vbSystem) = vbSystem Then
      If strFilename = "." Or strFilename = ".." Then
        GoTo Continue_Do
      End If
      Call colDirectories.Add(strPath & strFilename)
       
    ElseIf (fileAttr And vbNormal) = vbNormal And Not (fileAttr And vbSystem) = vbSystem Then
      If CheckFile(strPath & strFilename) Then
        Call FoundFiles.Add(strPath & strFilename)
      End If
       
    End If
     
Continue_Do:
    strFilename = Dir$()
  Loop
   
  DoEvents
  Dim vntDirectory As Variant
  For Each vntDirectory In colDirectories
    Call SearchFiles(CStr(vntDirectory), FoundFiles)
  Next
   
  SearchFiles = FoundFiles.Count
   
Exit Function

ErrHandler:
  'TODO: implement proper logging
  Debug.Print Format$(Now, "yyyy-mm-dd"); Tab(12); "'"; Err.Source; "'"; _
              Tab(2); "Path: '"; strPath & strFilename; "'"; _
              Tab(4); "=> '"; Err.Description; "'"
  Resume Next
End Function