Excel sayfasina isim ve fotograf ekleme

[halit3]

Sayın Halit3 Hocam,
Şuna bir bakar mısınız, lütfen? A0100 e kadar A sütununa yazılmış ve resimler C:\Foto\ subdir inde. Silme çalıştı ama Ekle çalışmadı. Acaba nerede hata yap mışım?
İlginize çok teşekkür ederim.
Saygılarımla

Resimler sayfaya alınınca belli bir sayıdan sonra birazcık bekletmek gerekiyor herhalde

kod:

Sub resim_ekle()
son = 3
ReDim uzanti(son)
uzanti(1) = ".bmp"
uzanti(2) = ".jpg"
uzanti(3) = ".gif"

Klasor = ThisWorkbook.Path & "\Resimler\"

For i = 2 To Cells(Rows.Count, "A").End(3).Row
isim = Cells(i, 1).Value
Set Adres = Cells(i, 2)


Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
yer1 = Adres.Address
If yer = yer1 Then
Picture.Delete
Exit For
End If
Next Picture


For j = 1 To son
Dosya = Klasor & isim & uzanti(j)
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
ActiveSheet.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Adres.Left + 2, Adres.Top + 2, Adres.Width - 4, Adres.Height - 4
ActiveSheet.Cells(i, 1).Select


[COLOR="Red"]sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:5"))
MsgBox "devam et"
sat1 = 0
End If[/COLOR]

Exit For
End If
Next

Next
End Sub

 

[Tevfik_Kursun]

Merhaba Halit3 Hocam,
Bekletmeyi bırak, hiç gelmiyor. Mutlaka bir sebebi vardır, ama ben bulamadım.
İyi çalışmalar
Saygılarımla

 

[halit3]

Merhaba Halit3 Hocam,
Bekletmeyi bırak, hiç gelmiyor. Mutlaka bir sebebi vardır, ama ben bulamadım.
İyi çalışmalar
Saygılarımla

A sütunundaki isimlere göre resimleri getirmekte.

kod:

Sub resim_ekle()
son = 3
ReDim uzanti(son)
uzanti(1) = ".bmp"
uzanti(2) = ".jpg"
uzanti(3) = ".gif"

'Klasor = ThisWorkbook.Path & "\Resimler\"

Set hedef = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not hedef Is Nothing Then
Klasor = hedef.SELF.Path
If InStr(1, Klasor, "{") > 0 Then GoTo Atla
If Right(Klasor, 1) <> "\" Then Klasor = Klasor & "\"



For i = 2 To Cells(Rows.Count, "A").End(3).Row
isim = Cells(i, 1).Value
Set Adres = Cells(i, 2)


Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
yer1 = Adres.Address
If yer = yer1 Then
Picture.Delete
Exit For
End If
Next Picture


For j = 1 To son
Dosya = Klasor & isim & uzanti(j)
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
ActiveSheet.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Adres.Left + 2, Adres.Top + 2, Adres.Width - 4, Adres.Height - 4
ActiveSheet.Cells(i, 1).Select
Exit For
End If
Next

Next
Range("a1").Select
MsgBox "işlem tamam"

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

 

[halit3]

Sayın Halit3 Hocam,
Şuna bir bakar mısınız, lütfen? A0100 e kadar A sütununa yazılmış ve resimler C:\Foto\ subdir inde. Silme çalıştı ama Ekle çalışmadı. Acaba nerede hata yap mışım?
İlginize çok teşekkür ederim.
Saygılarımla

Kodun burası yanlış

Klasor = ThisWorkbook.Path & "C:\Foto\"

yukarıdaki bölüm böyle olmalı

Klasor =  "C:\Foto\"

KOD:

Sub Resimleri_Ekle()
    Son = 6
        ReDim uzanti(Son)
            uzanti(1) = ".jpg"
            uzanti(2) = ".JPG"
            uzanti(3) = ".bmp"
            uzanti(4) = ".BMP"
            uzanti(5) = ".gif"
            uzanti(6) = ".GİF"
            
        

        Klasor = "C:\Foto\"

        For i = 2 To Cells(Rows.Count, "A").End(3).Row
            isim = Cells(i, 1).Value
        Set Adres = Cells(i, 2)


        Dim Picture As Object
            For Each Picture In ActiveSheet.Shapes
                yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
                yer1 = Adres.Address
                    If yer = yer1 Then
                        Picture.Delete
                        Exit For
                    End If
            Next Picture

            For j = 1 To Son
                Dosya = Klasor & isim & uzanti(j)
            
                        If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & isim & uzanti(j)) = True Then
                        ActiveSheet.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Adres.Left + 2, Adres.Top + 2, Adres.Width - 4, Adres.Height - 4
                        ActiveSheet.Cells(i, 1).Select
                        
sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:5"))
MsgBox "devam et"
sat1 = 0
End If

                        Exit For
                    End If
            Next

        Next
End Sub

 

[Tevfik_Kursun]

Çok teşekkür ederim Halit3 Hocam,
Zihninize sağlık. iyi çalışmalar