• DİKKAT

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

resim boyutu ayarlama

  • Konbuyu başlatan Konbuyu başlatan hamza02
  • Başlangıç tarihi Başlangıç tarihi
H

hamza02

Katılım
24 Mart 2021
Mesajlar
41
Excel Vers. ve Dili
Türkçe
Arkadaşlar herkese merhaba, aranıza yeni katıldım. yardımlarınız için şimdiden teşekkürler.

Aşağıdaki kod içinde Sayfa3 D5 hücresindeki resmin boyutunu ayarlamak istiyorum.




Private Sub ComboBox1_Change()

Sayfa3.Range("B2").Value = ComboBox1.Text 'B2 hücresine ComboBox ile Seçilen ÜRÜN ADI'nı yazar
Sayfa3.Range("B3") = WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A2:B1000"), 2, 0) 'B3 hücresine ÖLÇÜ BİRİMİ getirir
Sayfa3.Range("C3") = WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A2:C1000"), 3, 0) 'C3 hücresine FİYAT getirir
Sayfa3.Range("B5") = "BİRİM FİYAT : " & Sayfa3.Range("C3") & " / " & Sayfa3.Range("B3") 'B6 hücresine BİRİM FİYAT ı getirir
Sayfa3.Range("B6") = "ÜRETİM YERİ : " & WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A2:E1000"), 5, 0) 'B6 hücresine ÜRETİM YERİ ni getirir
Sayfa3.Range("B7") = "FİYAT DEĞİŞİM TARİHİ : " & Format(WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A2:F1000"), 6, 0), "dd.mm.yyyy") 'B6 hücresine FİYAT DEĞİŞİM TARİHİ ni getirir
Sayfa3.Range("C10") = WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A2:D1000"), 4, 0) 'B6 hücresine YERLİ - İTHAL bilgisini getirir

'HÜCRE İÇİNDEKİ RESMİ SİLER-1
With ActiveSheet
For Each Sh In .Shapes
If Not Application.Intersect(Sh.TopLeftCell, .Range("D5")) Is Nothing Then Sh.Delete
Next Sh
End With

If Sayfa3.Range("C10") = "Yerli" Then
Sayfa3.Range("P2").Copy Sayfa3.Range("D5")
End If

Sayfa3.Activate
Sayfa3.Range("D6").Select
Sayfa3.Range("D6").Copy
Sayfa3.Range("D5").PasteSpecial Paste:=xlPasteFormats
Sayfa3.Range("G2").Select
Sayfa3.Range("G2").Clear

Sayfa3.Range("G2").Select

End Sub
 
arkadaşlar size zahmet yardımcı olursanız sevinirim biraz acilde
 
Bu kodlar işinizi görür sanırım. D5 hücre iboyutuna göre resmi boyutlandırır.

Yanlız sayfa3 de birden fazla resim varsa; D5 deki resim seçip, excelde sol üstte hücre referanslarının gösterildiği kutucuktan resim ismine bakın.
Orda Resim 1 Resim 2 vb.. yazması lazım.
Bu koddaki 1'i orda yazan numaraya göre değiştirin.
Sayfa3.Shapes(1)


Kod: 
    picLeft = Sayfa3.Range("D5").Left + 1
    picTop = Sayfa3.Range("D5").Top + 1
    picWidth = Sayfa3.Range("D5").Width - 2
    picHeight = Sayfa3.Range("D5").Height - 2
       
    With Sayfa3.Shapes(1)
    .LockAspectRatio = msoFalse
    .Left = picLeft
    .Top = picTop
    .Height = picHeight
    .Width = picWidth
 
Yukarıda çıkmamış. En alta
End with
satırını ekleyin. :)
 
Sayın cengizdemir72 öncelikle yardımınız için teşekkür ederim. Ancak bu kodlar işime yaramadı çünkü resim adı değişiyor.
 
Dediğiniz doğru sayfada birden fazla resim var, combobox ile ürün adı seçiyorum seçilen ürün yerli malı ise D5 hücresine yerli malı logosu ekliyor ithal ürün ise logoyu siliyor ve kayıt sayfasında yüzlerce ürün var
 
O zaman başka bir üstad yardımcı olabilir sanırım.
D5 hucresindeki resim adını yada idsini öğrenebilecek bir kod yazabilirlerse shape(1) ona göre ayarlanır ve doğru resim seçilmiş olur.
 
Biraz araştırdım. Bu kodlar işinizi görür sanırım. ;) Range("A":Y1048576") alanını kendinize göre uyarlarsınız.

Kod: 
Sub Resim()


   Dim Resim As Picture, Alan As Range
    
    Set Alan = Sheets("Sayfa3").Range("A1:Y1048576")
    
    For Each Resim In ActiveSheet.Pictures
    Sat = Resim.TopLeftCell.Row
    Sut = Resim.TopLeftCell.Column
    
    If Sat = 5 And Sut = 4 Then
        picLeft = Sheets("Sayfa3").Range("D5").Left + 1
        picTop = Sheets("Sayfa3").Range("D5").Top + 1
        picWidth = Sheets("Sayfa3").Range("D5").Width - 2
        picHeight = Sheets("Sayfa3").Range("D5").Height - 2
        isim = Resim.Name
                
        With Sheets("Sayfa3").Shapes(isim)
        .LockAspectRatio = msoFalse
        .Left = picLeft
        .Top = picTop
        .Height = picHeight
        .Width = picWidth
        End With
     End If
        
    Next
    
Set Alan = Nothing

End Sub
 
Sayın cengizdemir72 hocam ilginize tekrar teşekkür ederim.
kodları denedim ama hata verdi bir türlü başaramadım muhtemelen bende kaynaklı sanırım, buraya excel dosyası nasıl ekleyebilirim acaba.
 
Sayın hamza02. rica ederim :)
Dosya.tc vb. gibi dosya ekleme sitelerine ekleyip, linkini koyabilirsiniz.

Yukarıdaki kodları Sub Resim() ve en alttaki End Sub olmadan, makronuzdaki aşağıda belirttiğim iki satırın arasına ekleyip dener misiniz ?

Olmazsa dosyayı eklediğinizde ben bakabilirim.

Sayfa3.Range("D5").PasteSpecial Paste:=xlPasteFormats

Kodlar buraya.......

Sayfa3.Range("G2").Select


hamza02' Alıntı:
Sayın cengizdemir72 hocam ilginize tekrar teşekkür ederim.
kodları denedim ama hata verdi bir türlü başaramadım muhtemelen bende kaynaklı sanırım, buraya excel dosyası nasıl ekleyebilirim acaba.
Genişletmek için tıkla ...
 
Makro kaydet ile gerekli kodları yazabilirsiniz.
 
Makro kaydeti çalıştırdığınız zaman, kodları otomatik olarak zaten o veriyor.Siz o kodları modüle kopyalacaksınız.
Makro kaydet diye arama yaparsanız,nasıl yapıldığını görebilirsiniz.
 

Barkod_deneme.xlsm

dosyayı indir, full download - Barkod_deneme.xlsm
dosya.org dosya.org

ilgili çalışmamı yükledim

sayın üstadlar yardımcı olursanız sevinirim
 
Merhabalar kodları dosyanıza göre uyarladım. Ama anlamadığım gerip bir sorun oluyor.
Eklediğiniz düğme ve comboboxdan dolayı kodlar çalışmıyor hata veriyor.
Sanki onları da resim olarak algılıyor ve resim olmadıkları için hata veriyor.
Onları silersem kodlar çalışıyor.
 
Sayın cengizdemir72 hocam peki ne yapabiliriz. Ben dosya üzerinde biraz daha çalıştım. Sizin kod bilgi seviyenizi bilmiyorum ama bu kod olayını iyi bilen bir üstad yardım etse çok iyi olur.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst