• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Proforma'ya Resim Çekme

I

ibrhmblc

Katılım
27 Ağustos 2020
Mesajlar
12
Excel Vers. ve Dili
Türkçe 2016
Merhabalar, çalıştığım iş yerinin proformasına otomatik resim çekmesi için bir vba kodu buldum ve uyguladım. Gayet düzgün çalışıyor ancak proformanın üstünde yer alan şirket logosunu siliyor. Nasıl düzeltebilirim?
 
Merhaba.

Muhtemelen kodlar resimleri eklemeden önce sayfada bulunan diğer resimler siliyor.
Kodlarda ".delete" ile biten satır varsa silin.

Eğer olmazsa-yapamazsanız dosyanızı ekleyin kontrol edelim.
 
Muzaffer Ali' Alıntı:
Merhaba.

Muhtemelen kodlar resimleri eklemeden önce sayfada bulunan diğer resimler siliyor.
Kodlarda ".delete" ile biten satır varsa silin.

Eğer olmazsa-yapamazsanız dosyanızı ekleyin kontrol edelim.
Genişletmek için tıkla ...

Muzaffer hocam, bir sorum daha olacak. Proformanın yukarısında iki logo bulunuyor. .delete kodunu sildiğim için kodları değiştirirken veya eklerken eski resimler arkada kalıyor. B1:B20 arasını pas geçmesini sağlayabilir miyim .delete kodunun.

Kod: 
Public Function DosyaVarmi(dosyayolu As String) As Boolean
    On Error GoTo Çıkış
    If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True
   
Çıkış:
    On Error GoTo 0
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub

On Error GoTo Çıkış:
ActiveSheet.DrawingObjects.Delete

Dim ResimDosyaYolu As String
Dim Resim As Object
For i = 20 To 31
   
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"

    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
        Else
           ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
        End If
       
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
   
     With Range("j" & i)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With

Next i

Çıkış:

End Sub
 
Hücre adresine göre değil, resim adına göre yapılabilir.
Dosyanızı paylaşırsanız yapabiliriz.

Dosyanızda özel şeyler varsa onları silin.
Sadece Logolar kalsın. Yani sürekli sabit kalacak olan resimler kalsın.

Eğer dosyanız özel değilse tamamını paylaşın..
 
Muzaffer Ali' Alıntı:
Hücre adresine göre değil, resim adına göre yapılabilir.
Dosyanızı paylaşırsanız yapabiliriz.

Dosyanızda özel şeyler varsa onları silin.
Sadece Logolar kalsın. Yani sürekli sabit kalacak olan resimler kalsın.

Eğer dosyanız özel değilse tamamını paylaşın..
Genişletmek için tıkla ...

hocam altın üye olmadığım için dosya ekleyemiyorum sanırım. Ekran Alıntısı.PNG olarak geçiyor resimler
 
dosya.tc gibi bir paylaşım sitesine ekleyip linkini buraya kopyalayın.
 
Yukarıda eklediğiniz kod ile dosyanızdaki aynı değil.

Ayrıca dosyadaki kodları silerken yanlışlıkla sildiğiniz yerler var.

Dosyanızın kod kısmında hiçbir şey silmeden gönderirseniz çözmeye çalışabilirim.
 
Private Sub Worksheet_Change kodlarını aşağıdaki ile değiştirin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub
On Error GoTo Çıkış:
Dim Bak As Integer
    For Bak = DrawingObjects.Count To 1 Step -1
        MsgBox Sayfa1.DrawingObjects.Count
        If Not DrawingObjects(Bak).Name = "1 Resim" And Not DrawingObjects(Bak).Name = "2 Resim" Then
            DrawingObjects(Bak).Delete
        End If
    Next
Dim ResimDosyaYolu As String
Dim Resim As Object
For i = 20 To 31
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
        Else
           ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
        End If
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     With Range("j" & i)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With
Next i
Çıkış:
End Sub
 
Muzaffer Ali' Alıntı:
Private Sub Worksheet_Change kodlarını aşağıdaki ile değiştirin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub
On Error GoTo Çıkış:
Dim Bak As Integer
    For Bak = DrawingObjects.Count To 1 Step -1
        MsgBox Sayfa1.DrawingObjects.Count
        If Not DrawingObjects(Bak).Name = "1 Resim" And Not DrawingObjects(Bak).Name = "2 Resim" Then
            DrawingObjects(Bak).Delete
        End If
    Next
Dim ResimDosyaYolu As String
Dim Resim As Object
For i = 20 To 31
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
        Else
           ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
        End If
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     With Range("j" & i)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With
Next i
Çıkış:
End Sub
Genişletmek için tıkla ...

hocam teşekkürler fakat logolar silindi bende. Bende mi bir sorun var acaba
 
Ben Resimlerin isimlerini değiştirmiştim ondan kaynaklanıyor.
Kodlarda bulunan1 Resim ve 2 Resim yerine 4 Resim, 17 Resim yazın.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst