Soru Belirli Hücrelere Makro İle Sıralı Fotoğraf Ekleme

[Rizelli3]

Merhabalar,

Elimde bir dosya ve bine yakın resim var resimler klasör içinde sıralı göz at butonuna tıkladığımda Excel'de belirli hücrelere sıralı ve her sayfada 4 adet olacak şekilde fotoğrafları atmasını istiyorum ve mümkünse sil butonu ekleyerek eklenen resimlerin tamamının silinmesini istiyorum. Yapılabilir mi fikrim yok internette aradım işe yarar bilgi bulamadım. Destekleriniz için şimdiden teşekkür ederim.

Herkese sağlıklı günler dilerim.

Örnek dosyayı buradan indirebilirsiniz.

 

[Rizelli3]

Örnek bir dosya bulup durumu çözdüm belirttiğim hücrelere resimleri sıralı bir şekilde yüklüyor ancak sayfada bulunan diğer resimleri siliyor. Bunu engellememiz mümkün müdür. Yardımlarınız için şimdiden teşekkürler.

 

[Korhan Ayhan]

Bulduğunuz kodu paylaşın ki resimleri silen bölümü tespit edip size bilgi verebilelim.

 

[Rizelli3]

Bulduğunuz kodu paylaşın ki resimleri silen bölümü tespit edip size bilgi verebilelim.

Merhaba kod eklenmiştir.

Dim dosyaliste(1000, 2) As String
Dim say As Long
Dim i As Integer
Dim dosyaisim, dosyaadi, dosyauzantisi, numara As String

Sub menu()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Call degerleri_sifirla
    Call dosyayukle
    Call sirala
    Call resim_ekle
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub degerleri_sifirla()
  For i = 1 To 1000
    dosyaliste(i, 1) = ""
    dosyaliste(i, 2) = ""
  Next
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

Sub sirala()
    If WorksheetExists("xxxxSıralaxxxx") Then Sheets("xxxxSıralaxxxx").Delete
    Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
    NewSh.Name = "xxxxSıralaxxxx"
    Sheets("xxxxSıralaxxxx").Activate
    For i = 1 To say
      Cells(i, 1).Value = dosyaliste(i, 1)
      Cells(i, 2).Value = dosyaliste(i, 2)
      
    Next
    
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Range("A1:B" & sonsatir).Sort Range("B1"), 1
    For i = 1 To say
      dosyaliste(i, 1) = Cells(i, 1).Value
      dosyaliste(i, 2) = Cells(i, 2).Value
    Next
    Sheets("xxxxSıralaxxxx").Delete
End Sub

Sub resim_ekle()
  Dim sShape As Shape
 
  i = 0
  For Each ws In ActiveWorkbook.Worksheets
    If Left(ws.Name, 1) = "F" Then
        ws.Select
        For Each myPict In ws.Pictures
                myPict.Delete
        Next myPict

        i = i + 1
        If i > say Then Exit For
        Set Rng = Cells(9, "E")
        Rng.Select
        Set sShape = ActiveSheet.Shapes.AddPicture(dosyaliste(i, 1), msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
        i = i + 1
        If i > say Then Exit For
        Set Rng = Cells(9, "V")
        Rng.Select
        Set sShape = ActiveSheet.Shapes.AddPicture(dosyaliste(i, 1), msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
        i = i + 1
        If i > say Then Exit For
        Set Rng = Cells(39, "E")
        Rng.Select
        Set sShape = ActiveSheet.Shapes.AddPicture(dosyaliste(i, 1), msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
        i = i + 1
        If i > say Then Exit For
        Set Rng = Cells(39, "V")
        Rng.Select
        Set sShape = ActiveSheet.Shapes.AddPicture(dosyaliste(i, 1), msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
    
     End If
  Next
End Sub


Sub dosyayukle()
  Dim satir As Long
  Dim xDirect$, xFname$, InitialFoldr$
  say = 0
  InitialFoldr$ = ActiveWorkbook.Path
  With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Application.DefaultFilePath & "\"
    .Title = "Please select a folder to list Files from"
    .InitialFileName = InitialFoldr$
    .Show
    If .SelectedItems.Count <> 0 Then
       xDirect$ = .SelectedItems(1) & "\"
       xFname$ = Dir(xDirect$ & "*.jpg")
       Do While xFname$ <> ""
         say = say + 1
         dosyaliste(say, 1) = xDirect$ & xFname$
         dosyaadi = xFname$
         Call isim_uzanti
         dosyaliste(say, 2) = numara
         xFname$ = Dir
       Loop
     End If
   End With
End Sub

 

[Korhan Ayhan]

resim_ekle makrosundaki aşağıdaki bölümü silip deneyiniz.

For Each myPict In ws.Pictures
myPict.Delete
Next myPict

 

[Rizelli3]

resim_ekle makrosundaki aşağıdaki bölümü silip deneyiniz.

Çok teşekkür ederim.

 

[Rizelli3]

resim_ekle makrosundaki aşağıdaki bölümü silip deneyiniz.

Son bir sorum daha olacak hocam peki sadece makro ile eklediğim resimleri silmem mümkün müdür? Örnek dosyada tümünü sil diye bir kod var ancak o malesef ele eklediğim silinmemesi gereken resimleri de siliyor.

Sub tumresimleri_sil()
  For Each ws In ActiveWorkbook.Worksheets
    If Left(ws.Name, 1) = "F" Then
        ws.Select
        For Each myPict In ws.Pictures
                myPict.Delete
        Next myPict
     End If
   Next
End Sub