Halli, Hallo, Hallöle...

Nach langem hin und her bin ich in meinem Projekt weiter gekommen. Nun hängt es aber leider wieder...

Ich schaffe es nicht dass Kommentare mit dem Bild als Hintergrund und die Hyperlinks zu den Bildern in der richtigen Zelle hinterlegt werden. 

Beim Debuggen werden alle benötigten Informationen von colCleanfiles, colfiles, xRgBezeichnung und results vollständig an die Function übergeben. In der  "Private Function CommentHyperlink" an der Position "Set cmt = xRgBezeichnung(cy, 1).AddComment" kommt der Laufzeitfehler '1004': Anwendungs- oder objektdefinerter Fehler. Für Ideen und vorschläge bin ich durchaus offen. Im anschluss der vollständige Code:
 

Option Explicit

'////////////////////////////////////////////////
'// Auswählen eines Ordners in dem die Benötigeten
'// Bilddateien hinterlegt sind
'// Es werden alle Unterordner durchsucht und es wird
'// eine Sammlung der Dateien erstellt.
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 kommt eine Warnung
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
      Set colFiles = New Collection

    'Dateien im ausgewählten Ordner suchen und zur Sammlung hinzufügen
    SearchFiles strSelectedPath, colFiles

    If colFiles.Count = 0 Then
        MsgBox "Keine Treffer.", vbExclamation
        Exit Sub
    End If
    
    ' Anzahl der gefundenen Dateien anzeigen bei bedarf aktivieren!
    'MsgBox "Anzahl der gefundenen Dateien: " & colFiles.Count, vbInformation
    ' Übersicht der Dateien in der Sammlung
    'Dim j As Integer
    'For j = 1 To colFiles.Count
    'Debug.Print colFiles(j)
    'Next j
   
   
 Dim ColCleanedFiles As VBA.Collection
Set ColCleanedFiles = New Collection

Dim i As Integer
For i = 1 To colFiles.Count
    Dim filename As String
    filename = FoundFiles(colFiles(i))
    ColCleanedFiles.Add filename
Next i
    
    'Kontrolle über die Wertausgabe bei bedarf Aktivieren
    'For i = 1 To ColCleanedFiles.Count
    'Debug.Print ColCleanedFiles(i)
    'Next i
    
    Dim xRgBezeichnung As Excel.Range
    Dim results As Collection
    Set results = Kriterien(xRgBezeichnung)
    
    'Kontrolle über die Wertausgabe von results bei bedarf Aktivieren
    'Dim result As Variant
    'For Each result In results
    'Debug.Print result
    'Next result

    CommentHyperlink colFiles, ColCleanedFiles, results, xRgBezeichnung

End Sub

'////////////////////////////////////////////////
'// Untersucht eine Dateiangabe nach bestimmten Kritieren.
'// Liefert: TRUE, wenn diese Datei berücksichtigt werden soll.
'//

Private Function CheckFile(FullFilename As String) As Boolean
   
  'nur PNG-Dateien berücksichtigen
  If Right$(FullFilename, 4) <> ".png" Then Exit Function
   
  CheckFile = True
    
    'Den Dateinamen aus dem FullFilename extrahieren
    Dim filename As String
    filename = GetFileName(FullFilename)

'Kontrolle über die Wertausgabe bei bedarf Aktivieren
'Debug.Print "CheckFile: " & CheckFile

End Function

'////////////////////////////////////////////////
'// Initialisiert um es für weitere schritten nutzen zu können
'//
'//

Private Function GetFileName(FullPath As String) As String

Dim arrPath() As String
arrPath = Split(FullPath, "\")
GetFileName = arrPath(UBound(arrPath))

'Kontrolle über die Wertausgabe bei bedarf Aktivieren
'Debug.Print "Der Dateiname ist: " & GetFileName

    'Funktionsaufruf von FoundFiles
    'FoundFiles GetFileName

End Function

'////////////////////////////////////////////////
'// Dateiname ist wie Folgt aufgebaut XX_XXXXX_Name_Bezeichnung_KurzBezeichnung_XXXXXXXX
'// X ist eine variable und soll nicht beachtet werden
'// Der Dateiname wird Zerlegt und Bereinigt um es
'// im Nächsten schritt mit den suchkriterien abzugleichen
'// der Dateiname wir in nameBezeichnungKurzbezeichnung
'// Am ende wird der Bereinigtename ausgegeben

'Dateinamen anpassen
Private Function FoundFiles(ByVal filename As String) As String
    
'Beim Dateinamen die Kriterien selectieren
filename = ModifyFilename(filename)
    
If UBound(Split(filename, "_")) >= 4 Then
    Dim parts() As String
    parts = Split(filename, "_")
    filename = parts(2) & parts(3) & parts(4)
End If

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

Dim i As Integer
For i = 1 To Len(specialChars)
    filename = Replace(filename, Mid(specialChars, i, 1), "")
Next i

' Entferne Leerzeichen im Dateinamen
filename = Replace(filename, " ", "")

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

FoundFiles = filename

'Kontrolle der Ergebnisse bei Bedarf aktivieren
'Debug.Print "fileName: " & filename

End Function


'////////////////////////////////////////////////
'// Um Regelkarten die auserhalb der Norm sind auf die
'// benötigten gegebenheiten anzupassen wird vor dem
'// erstellen des vermeintlichen Dateinamens eine
'// Funktion durchlaufen die die Dateinamen so zuschneidet,
'// dass diese in ein Dateinamen umgewandelt werden können


Private Function ModifyFilename(ByVal filename As String) As String
Dim parts() As String
parts = Split(filename, "_")

' Überprüfe, ob ein Punkt vor dem zweiten Unterstrich steht
If UBound(parts) >= 2 Then
    Dim secondPart As String
    secondPart = parts(1)

    If InStr(secondPart, ".") > 0 Then
        parts(1) = Replace(secondPart, ".", "")
    End If

    filename = Join(parts, "_")
End If

' Überprüfe, ob nach dem ersten Unterstrich "fettansatz1_2" steht
' durch den Unterstricht wird der Dateiname ansonsten verfälscht
If InStr(filename, "_") > 0 Then
    Dim firstPart As String
    firstPart = Split(filename, "_")(0)
    secondPart = Split(filename, "_")(1)

    If secondPart = "fettansatz1" & Chr(95) & "2" Then
        filename = firstPart & "_fettansatz12"
    End If
End If

' Entferne .png aus dem Dateinamen
filename = Replace(filename, ".png", "")

ModifyFilename = filename

End Function




'////////////////////////////////////////////////
'// Damit die Bilder richtig zugeordnet werden, muss ein
'// abgleich mit dem Dateinamen erfolgen. Hierzu werden
'// die Kriterien aus der Tabelle ausgewählt und zur
'// weiterverarbeitung bereit gestellt.

Private Function Kriterien(xRgBezeichnung As Excel.Range) As Collection
    ' Kriterien Auswählen
    Dim XRgName As Excel.Range
    Dim XRgKurzbezeichnung As Excel.Range
    Dim searchTerm1 As String

    ' Hier wird die Bezeichnung ausgewählt und der Hyperlink und das Bild hinterlegt
    Set xRgBezeichnung = Application.InputBox("Bitte den Bereich mit der Bezeichnung auswählen:", "Bitte die Spalte wählen", Type:=8)
    'Zum Überprüfen der Range aktivieren wen nötig
    'MsgBox xRgBezeichnung.Address
    If xRgBezeichnung Is Nothing Then Exit Function

    Call Delete(xRgBezeichnung)

    ' 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 Function

    ' 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 Function

    Dim cy As Long
    cy = 1

    ' Container für die Ergebnisse
    Dim results As Collection
    Set results = New Collection

    ' Schleife über die gesamte Range
    Do While XRgName(cy, 1) <> ""
        ' Aus den Kriterien wird der mögliche Dateiname erstellt
        searchTerm1 = XRgName(cy, 1) & xRgBezeichnung(cy, 1) & XRgKurzbezeichnung(cy, 1)

        ' Ergebnis von Searchterm1 anzeigen (optional)
        'Debug.Print searchTerm1

        ' Aufruf der NormalizeName-Funktion und Zuweisung des Rückgabewerts
        Dim normalizedTerm As String
        normalizedTerm = NormalizeName(searchTerm1)

        ' Ergebnis zur Ergebnis-Collection hinzufügen
        results.Add normalizedTerm
        cy = cy + 1

    Loop

' Überprüfe, ob die Range durchlaufen wurde
If XRgName(cy, 1) = "" Then

End If

' Ausgabe des Inhalts der Ergebnis-Collection
'Dim result As Variant
'For Each result In Results
    'Debug.Print result
'Next result

' Gib die Ergebnis-Collection zurück
Set Kriterien = results

End Function

'////////////////////////////////////////////////
'// Damit ein Abgleich richtig erfolgen kann, müssen
'// die Kriterien in der Art und Weis wie der Dateiname
'// aufgebaut werden. Hierzu wird die selbe Prozedur
'// durchgeführt wie beim Dateinmaen

Private Function NormalizeName(ByVal searchTerm1 As String) As String

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

Dim i As Integer
For i = 1 To Len(specialChars)
searchTerm1 = Replace(searchTerm1, Mid(specialChars, i, 1), "")
Next i

'Einheitliche Groß- und Kleinschreibung
searchTerm1 = LCase(Trim(searchTerm1))

'Entfernt Leerzeichen
searchTerm1 = Replace(searchTerm1, " ", "")

'Ergebnis von searchTerm1 (nach Bereinigung) anzeigen
'Wenn nötig, aktivieren
'Debug.Print searchTerm1

'Speichern des normalisierten Namens
NormalizeName = searchTerm1

End Function





'////////////////////////////////////////////////
'// Um sicherzustellen, das es zu keinen Komplikationen
'// kommt, werden alle zuvor Hinterlegten Kommentare
'// und Hyperlinks in der Spalte Bezeichnung gelöscht.
'// Dieser schritt ist nur zur sicherheit um mögliche
'// eventualitäten auszuschließen

Private Function Delete(xRgBezeichnung As Excel.Range)

' Lösche alle Kommentare und Hyperlinks im ausgewählten Bereich
Dim cy As Long

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
  
Next

End Function



'////////////////////////////////////////////////
'// In diesem Schritt wird geprüft ob der Dateiname
'// und die Kriterien übereinstimmen. Wen es dem so
'// ist, wird das Bild im Kommentarfenster als Hinter-
'// grund hinterlegt und auf die Bezeichnung ein Hyper-
'// link zum Bild hinterlegt.


Private Function CommentHyperlink(colFiles As VBA.Collection, ColCleanedFiles As VBA.Collection, results As Collection, xRgBezeichnung As Excel.Range) As Boolean
    Dim cmt As Comment
    Dim cy As Long
    Dim cleanedFile As Variant
    Dim result As Variant
    Dim file As Variant
        
    cy = 1

For Each cleanedFile In ColCleanedFiles
    For Each result In results
        If cleanedFile = result Then
            ' Add hyperlink
            xRgBezeichnung(cy, 1).Hyperlinks.Add Anchor:=xRgBezeichnung(cy, 1), Address:=colFiles(cy)

            ' Add comment
            Set cmt = xRgBezeichnung(cy, 1).AddComment
            With cmt
                .Shape.Fill.UserPicture colFiles(cy)
                .Shape.Height = 260
                .Shape.Width = 520
                .Shape.LockAspectRatio = msoFalse
            End With
        End If
    Next result
    cy = cy + 1
Next cleanedFile

CommentHyperlink = True

        If CommentHyperlink = False Then
            MsgBox "Die Datei: " & colFiles(file) & " kann nicht zugeordnet werden. Auf korrekten Dateinamen prüfen!", vbCritical Or vbOKOnly, "/ Problem"
        End If

        cy = cy + 1

End Function
 
'////////////////////////////////////////////////
'// Durchsucht alle Unterordner nach bestimmten Dateien.
'// - siehe auch: CheckFile()
'// Liefert:
'//   Die Anzahl der Dateien in 'FoundFiles'.

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