Guten Tag ihr Lieben Excel-Götter,
ich hätte mal wieder ein Anliegen. Eins vor weck ich bin absolut VBA-Unerfahren. Ich habe mit mühe und Not eine Makro erstellt. Jetzt hab ich leider das Problem das dieses Makro Zuviel Arbeitsspeicher benötigt. Da der Arbeitgeber die IT-Hardware nicht aufrüsten wird, wollte ich fragen ob jemand mir dabei Helfen kann das Makro so umzugestalten, dass es weniger Arbeitsspeicher benötigt. Zudem kam beim erstellen irgendwann der Punkt dass die MsgBox nicht mehr getriggert wurde. Ich weiß nicht ob es möglich ist oder sinnhaft ist, aber vielleicht kann man das Problem ja über Funktion lösen. Sprich wen die einzelnen Überprüfungen als separate Funktionen laufen.

Hier das Makro:

Option Explicit


Sub Bild_und_Hyperlink()
Dim xFDObject As FileDialog
Dim xStrPath As String
Dim xStrPicPath As String
Dim xRgName As Range
Dim xRgKurzbezeichnung As Range
Dim xRgInsertBezeichnung As Range
Dim xRg As Range
Dim searchTerm1 As String
Dim split_filename As String
Dim cmt As Comment
Dim cy As Long
Dim file As Variant
Dim FileSystemObject As Object

Application.ScreenUpdating = False

'Ordner der Bilder
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFDObject = Application.FileDialog(msoFileDialogFolderPicker)

With xFDObject
.Title = "Bitte den Ordner für die Bilder wählen:"
.InitialFileName = Application.ActiveWorkbook.Path
.Show
.AllowMultiSelect = False
End With

'Nur wenn ein Ordner angewählt wurde
If xFDObject.SelectedItems.Count > 0 Then
xStrPath = xFDObject.SelectedItems.Item(1)
Else
MsgBox "Keinen Ordner Ausgewählt", vbInformation Or vbOKOnly, "/ Information"
Exit Sub
End If

'Hier wird die Bezeichnung ausgewählt + später Hyperlink zum Bild
Set xRgInsertBezeichnung = Application.InputBox("Bitte den Bereich für die Bezeichnung auswählen:", "Bitte die Spalte wählen", Type:=8)
If xRgInsertBezeichnung Is Nothing Then Exit Sub

'Hier wird die Kurzbezeichnung ausgewählt
Set xRgKurzbezeichnung = Application.InputBox("Bitte den Bereich für die Kurzbezeichnung 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 für den Namen wählen:", "Bitte die Spalte anwählen", Type:=8)
If xRgName Is Nothing Then Exit Sub

' Lösche alle Kommentare und Hyperlinks im ausgewählten Bereich
For cy = 1 To xRgInsertBezeichnung.Count
If xRgInsertBezeichnung(cy, 1).Value2 = "" Then Exit For
If Not xRgInsertBezeichnung(cy, 1).Comment Is Nothing Then xRgInsertBezeichnung(cy, 1).Comment.Delete
If Not xRgInsertBezeichnung(cy, 1).Hyperlinks Is Nothing Then xRgInsertBezeichnung(cy, 1).Hyperlinks.Delete
Next

'Alle Datein im Ordner und Unterordnern durchlaufen
RecursiveSearch xStrPath, xRgName, xRgKurzbezeichnung, xRgInsertBezeichnung, FileSystemObject

Application.ScreenUpdating = True

End Sub


Sub RecursiveSearch(ByVal folderPath As String, ByVal xRgName As Range, ByVal xRgKurzbezeichnung As Range, ByVal xRgInsertBezeichnung As Range, ByVal FileSystemObject As Object)
Dim file As Object
Dim folder As Object
Dim subFolder As Object
Dim searchTerm1 As String
Dim split_filename As String
Dim cmt As Comment
Dim cy As Long
Dim xStrPath As String
Dim xStrPicPath As String

Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
xStrPath = folderPath
Application.ScreenUpdating = False

'Alle Datein im Ordner durchlaufen
For Each file In FileSystemObject.GetFolder(xStrPath).Files

'String vom Dateinamen säubern
If UBound(Split(file.Name, "_")) = 4 Then
split_filename = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Split(file.Name, "_")(2), " ", ""), ",", ""), "-", ""), "%", ""), "&", ""), "/", ""), "(", ""), ")", ""), "\", ""), """", ""), ":", ""), ";", ""), "+", "") & _
Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Split(file.Name, "_")(4), " ", ""), ",", ""), "-", ""), "%", ""), "&", ""), "/", ""), "(", ""), ")", ""), "\", ""), """", ""), ":", ""), ";", ""), "+", ""), ".png", "") & _
Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Split(file.Name, "_")(3), " ", ""), ",", ""), "-", ""), "%", ""), "&", ""), "/", ""), "(", ""), ")", ""), "\", ""), """", ""), ":", ""), ";", ""), "+", "")

' Überprüfen, ob der Dateiname "thumbs.dp" enthält
If InStr(file.Name, "thumbs.dp") = 0 Then
cy = 1
Do While xRgName(cy, 1).Value2 > ""


'String der Namen säubert
searchTerm1 = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(xRgName(cy, 1), " ", ""), ",", ""), "-", ""), "%", ""), "&", ""), "/", ""), "(", ""), ")", ""), "\", ""), """", ""), ":", ""), ";", ""), "+", "") & _
Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(xRgKurzbezeichnung(cy, 1), " ", ""), ",", ""), "-", ""), "%", ""), "&", ""), "/", ""), "(", ""), ")", ""), "\", ""), """", ""), ":", ""), ";", ""), "+", "") & _
Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(xRgInsertBezeichnung(cy, 1), " ", ""), ",", ""), "-", ""), "%", ""), "&", ""), "/", ""), "(", ""), ")", ""), "\", ""), """", ""), ":", ""), ";", ""), "+", "")

'Beide miteinander vergleichen
If searchTerm1 = split_filename Then

'Hyperlink zur Datei in die Zelle setzen
ActiveSheet.Hyperlinks.Add xRgInsertBezeichnung(cy, 1), Address:=file.Path

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

cy = cy + 1
Loop

Else
MsgBox "Die Datei: " & file.Name & " kann nicht zugeordnet werden. Auf Korrekten Dateiname achten!", vbCritical Or vbOKOnly, "/ Problem"
End If


Next

' Durchsuche alle Unterordner im aktuellen Ordner
Set folder = FileSystemObject.GetFolder(folderPath)
For Each subFolder In folder.SubFolders
RecursiveSearch subFolder.Path, xRgName, xRgKurzbezeichnung, xRgInsertBezeichnung, FileSystemObject
Next subFolder

Application.ScreenUpdating = True

End Sub