Thema Datum  Von Nutzer Rating
Antwort
Rot Ein Makro soll alle Unterordner mit einbeziehen
07.08.2023 13:32:24 Sven
Solved
07.08.2023 14:20:35 Gast49419
NotSolved
07.08.2023 15:22:44 Sven
NotSolved
07.08.2023 17:50:15 Gast78637
NotSolved
07.08.2023 18:16:20 Sven
NotSolved
07.08.2023 18:34:19 Gast59948
NotSolved
08.08.2023 06:58:57 Sven
NotSolved
08.08.2023 11:16:16 Gast40343
NotSolved
14.08.2023 15:05:32 Sven
NotSolved
15.08.2023 00:03:25 Gast27989
NotSolved
15.08.2023 08:25:11 Sven
NotSolved
15.08.2023 13:24:52 Gast20621
NotSolved
15.08.2023 14:27:50 Sven
NotSolved
16.08.2023 10:01:05 Gast11842
NotSolved
16.08.2023 12:09:31 Sven
NotSolved
16.08.2023 18:39:13 Gast50512
NotSolved
06.09.2023 11:24:56 Sven
NotSolved
07.09.2023 18:03:43 Gast32657
NotSolved
08.09.2023 11:25:14 sven
NotSolved
08.09.2023 14:47:37 Gast54751
NotSolved
08.09.2023 15:05:17 Gast74933
NotSolved
08.09.2023 17:41:50 Gast28898
NotSolved
11.09.2023 07:44:00 Sven
NotSolved
11.09.2023 14:06:32 Gast56381
NotSolved
07.08.2023 17:10:58 ralf_b
Solved
07.08.2023 18:09:35 Sven
NotSolved
07.08.2023 18:12:02 ralf_b
NotSolved
07.08.2023 18:17:57 Sven
NotSolved

Ansicht des Beitrags:
Von:
Sven
Datum:
07.08.2023 13:32:24
Views:
419
Rating: Antwort:
 Nein
Thema:
Ein Makro soll alle Unterordner mit einbeziehen

Guten Tag, 

ich hätte mal wieder ein anliegen. Ich hab ein Makro welches nicht nur die Dateien im gewählten Ordner bearbeitet soll, sondern auch alle unterordner mit einbezieht. Es handelt sich dabei um den Unten eingefügten Code. Ich hatte es mal umgeschrieben und es rekursiv durch alle Ordner laufen lasse, dies hat leider zuviel Arbeitsspeicher benötigt und hat nicht mehr funktioniert. Kennt jemand eine Alternative? Da ich mich mit VBA-Kaum auskenne wäre es auch nett, wen ihr mir verratet wo der Code hinkommt. 

MFG Sven

Option Explicit

Sub BilderKommentarundHyperlink()

Dim xFDObject As FileDialog
Dim xStrPath, xStrPicPath As String

Dim XRgName As Range
Dim XRgKurzbezeichnung As Range
Dim XRgBezeichnung 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 T As Variant
Dim T1 As Variant

Dim FileSystemObject As Object

Application.ScreenUpdating = False


'Ordner mit den Bildern
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
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 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 Hyperlink und 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 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

'Hier wird die KKurzbezeichnung 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


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


'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 = Split(file.Name, "_")(2) & ", " & Split(file.Name, "_")(4) & ", " & Split(file.Name, "_")(3)
        For Each T In Array(" ", ",", "-", "%", "&", "/", "(", ")", "\", """", ":", ";", "+", ".png")
            split_filename = Replace(split_filename, T, "")
        Next

        
        ' Ü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 Beschreibung säubern
        searchTerm1 = XRgName(cy, 1) & XRgKurzbezeichnung(cy, 1) & XRgBezeichnung(cy, 1)
        For Each T1 In Array(" ", ",", "-", "%", "&", "/", "(", ")", "\", """", ":", ";", "+", ".png")
            searchTerm1 = Replace(searchTerm1, T1, "")
        Next
        
        'Beide miteinander vergleichen
        If searchTerm1 = split_filename Then
            
        'Hyperlink zur Datei in die Zelle setzen
        ActiveSheet.Hyperlinks.Add XRgBezeichnung(cy, 1), Address:=file.Path
            
        'Kommentar für die Zelle festlegen
        Set cmt = XRgBezeichnung(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 prüfen!", vbCritical Or vbOKOnly, "/ Problem"
        End If
        
  
    Next
    
Application.ScreenUpdating = True

End Sub

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Ein Makro soll alle Unterordner mit einbeziehen
07.08.2023 13:32:24 Sven
Solved
07.08.2023 14:20:35 Gast49419
NotSolved
07.08.2023 15:22:44 Sven
NotSolved
07.08.2023 17:50:15 Gast78637
NotSolved
07.08.2023 18:16:20 Sven
NotSolved
07.08.2023 18:34:19 Gast59948
NotSolved
08.08.2023 06:58:57 Sven
NotSolved
08.08.2023 11:16:16 Gast40343
NotSolved
14.08.2023 15:05:32 Sven
NotSolved
15.08.2023 00:03:25 Gast27989
NotSolved
15.08.2023 08:25:11 Sven
NotSolved
15.08.2023 13:24:52 Gast20621
NotSolved
15.08.2023 14:27:50 Sven
NotSolved
16.08.2023 10:01:05 Gast11842
NotSolved
16.08.2023 12:09:31 Sven
NotSolved
16.08.2023 18:39:13 Gast50512
NotSolved
06.09.2023 11:24:56 Sven
NotSolved
07.09.2023 18:03:43 Gast32657
NotSolved
08.09.2023 11:25:14 sven
NotSolved
08.09.2023 14:47:37 Gast54751
NotSolved
08.09.2023 15:05:17 Gast74933
NotSolved
08.09.2023 17:41:50 Gast28898
NotSolved
11.09.2023 07:44:00 Sven
NotSolved
11.09.2023 14:06:32 Gast56381
NotSolved
07.08.2023 17:10:58 ralf_b
Solved
07.08.2023 18:09:35 Sven
NotSolved
07.08.2023 18:12:02 ralf_b
NotSolved
07.08.2023 18:17:57 Sven
NotSolved