Sicile Göre Klasörden Resim Çağırma

Private Sub Workbook_Open()
    Sheets("Giriş").Activate
End Sub

Sub ACIKLAMAYA_RESIM_EKLE()
Set dosya = CreateObject("Scripting.FileSystemObject")
Set s1 = Sheets("1.İd.")
s1.Rows.Hidden = False
For sat = 3 To s1.Cells(Rows.Count, 2).End(3).Row Step 3
    For sut = 2 To 10 Step 2
        With s1.Cells(sat, sut)
            If .Text <> "" Then
                yol_isim_uzanti = [B][COLOR=rgb(132, 53, 52)]ThisWorkbook.Path[/COLOR][/B] & "\" & .Text & ".jpg"
                resim_varmi = dosya.FileExists(yol_isim_uzanti)
                Set aciklama_metni = .Comment
                If resim_varmi = True Then
                    .ClearComments
                    Set aciklama = .AddComment
                    aciklama.Shape.Fill.UserPicture yol_isim_uzanti
                    With .Comment.Shape
                        .Width = Cells(sat, sut).Width - 2: .Height = Cells(sat, sut).Height - 2
                        .Top = Cells(sat, sut).Top + 1: .Left = Cells(sat, sut).Left + 1
                    End With
                    .Comment.Visible = True
                End If
            End If
        End With
    Next
    If Not say > 0 Then s1.Rows(sat - 1 & ":" & sat + 1).Hidden = True
    say = 0
Next
MsgBox "Resimler hücre açıklamalarına eklendi..", vbInformation, "..:: Ömer BARAN ::.."
End Sub

Sub ACIKLAMAYA_RESIM_EKLE()
Set dosya = CreateObject("Scripting.FileSystemObject")
Set g = ThisWorkbook.Sheets("Giriş")
g.Range("S4:S" & Rows.Count).ClearContents
For Each shf In ThisWorkbook.Sheets
    If Not shf.[F1].Value = Empty Then
        shf.Rows.Hidden = False
        shf.Cells.ClearComments
        For sat = 3 To shf.Cells(Rows.Count, 2).End(3).Row Step 3
            For sut = 2 To 10 Step 2
                With shf.Cells(sat, sut)
                    If .Text <> "" Then
                        yol_isim_uzanti = ThisWorkbook.Path & "\" & .Text & ".jpg"
                        resim_varmi = dosya.FileExists(yol_isim_uzanti)
                        If resim_varmi = False Then
                            yol_isim_uzanti = ThisWorkbook.Path & "\YOK.jpg"
                            gsat = WorksheetFunction.Max(4, g.Cells(Rows.Count, "S").End(3).Row + 1)
                            g.Cells(gsat, "S") = shf.[F1] & " - " & shf.Cells(sat, sut).Value & " - " & shf.Cells(sat + 1, sut)
                        End If
                        Set aciklama_metni = .Comment
                        .ClearComments
                        Set aciklama = .AddComment
                        aciklama.Shape.Fill.UserPicture yol_isim_uzanti
                        With .Comment.Shape
                            .Width = shf.Cells(sat, sut).Width - 2: .Height = shf.Cells(sat, sut).Height - 2
                            .Top = shf.Cells(sat, sut).Top + 1: .Left = shf.Cells(sat, sut).Left + 1
                        End With
                        .Comment.Visible = True
                    Else: say = say + 1
                    End If
                End With
            Next
            If say = 5 Then shf.Rows(sat - 1 & ":" & sat + 1).Hidden = True
            say = 0
        Next
    End If
Next:   g.Columns("S").AutoFit
MsgBox "Resimler hücre açıklamalarına eklendi..", vbInformation, "..:: Ömer BARAN ::.."
End Sub

https://dosya.altervista.org/download.php?file=8b4ce62702a214b3a0ffc42ac449cb8d']http://dosya.altervista.org/download.php?file=8b4ce62702a214b3a0ffc42ac449cb8d