Soru Hücre karşılığına resim getirme

[mukoli]

Merhabalar ekteki dosyada resimler ve excel dosyası bulunmaktadır. yapmak istediğim a sütununda barkodlara göre resimleri resim sütununa getirmesi resim boyutunu örnekteki gibi ayarlarsa ona göre çok iyi olur. Teşekkür ederim

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodu bir modüle kopyalayıp çalıştırın.
Ancak resim boyutu örnekteki gibi olsun demişsiniz. Satır dar, foto büyük olunca fotolar üst üste biniyorlar.
Foto boyutu pic.ShapeRange.Height = 90 satırı ile düzenleniyor. İsterseniz değiştirebilirsiniz.

Sub Test()
    Dim Bak As Long
    Dim syf As Worksheet
    Dim pic As Variant
    With Worksheets("Sayfa1")
        For Bak = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
            Set pic = .Pictures.Insert(ThisWorkbook.Path & "\" & .Cells(Bak, "A") & ".jpg")
            pic.ShapeRange.Height = 90
            pic.Top = Cells(Bak, "F").Top
            pic.Left = Cells(Bak, "F").Left + 5
        Next
    End With
End Sub

 

[mukoli]

Teşekkür ederim hocam hücreye göre boyutlandırma yapılsa çok iyi olur. Birde bir satırı hücre boyutunu ayarladım 500 satır aynı boy genişlik yapılabilirmi .

 

[Muzaffer Ali]

pic.ShapeRange.Height = 90 satırı yerine pic.ShapeRange.Height = Cells(Bak, "F").Height satırını kopyalayın. Hangi hücreye göre boyutlanacaksa "F" yerine o hücrenin kolon harfini yazın.

Eğer yapamazsanız, olmasını istediğiniz hali ile örnek dosyanızı yeniden yükleyin. Resimleri yüklemenize gerek yok.

 

[mukoli]

pic.ShapeRange.Height = Cells(Bak, "F").Height Bu şekilde oldu hocam teşekkür ederim . Makroyu çalıştırmadan önceki resimleri silmesini sağlayabilirmiyiz . Diğer satırları alttaki resimdeki gibi olması

 

[Muzaffer Ali]

Aşağıdaki kodu kullanın. Koda açıklamalar yazdım gerekli gördüğünüz yer varsa değiştirirsiniz.

Sub Test()
    Dim Bak As Long
    Dim syf As Worksheet
    Dim pic As Variant
    Application.ScreenUpdating = False
    With Worksheets("Sayfa1")
        If .Shapes.Count > 0 Then .Shapes.SelectAll: Selection.Delete
        .Columns("F").ColumnWidth = 20 'Kolon genişliği
        For Bak = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
            .Rows(Bak).RowHeight = 90 'Satır genişliği
            Set pic = .Pictures.Insert(ThisWorkbook.Path & "\" & .Cells(Bak, "A") & ".jpg")
            pic.ShapeRange.Height = 90 'Foto yüksekliği
            pic.Top = Cells(Bak, "F").Top 'Fotonun yukarıya konumu
            pic.Left = Cells(Bak, "F").Left + 5 'Fotonun Sola konumu
        Next
    End With
    Application.ScreenUpdating = True
End Sub

 

[mukoli]

Çok teşekkür ederim istediğim gibi oldu

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.

 

[mukoli]

Merhaba hocam özür dileyerekden kodunuz çok işime yaradı tekrardan teşekkür ederim . Sayfayı farklı kaydetmek istiyorum ama resimleri getiremiyorum oldugu gibi kaydetmek için nasıl yapabiliriz . Masaüstüne kadyetmesi yeterki

 

[Muzaffer Ali]

Resimler Excel dosyası içine kaydediliyor. Dosyayı farklı bir yere kaydetseniz bile resimlerde dosya içinde kalır.
Resimleri de kopyalamak istiyorsanız onları ayrıca kopyalamalısınız.

 

[mukoli]

Evet hocam bu şekilde yaptım ama olmadı

Private Sub CommandButton2_Click()
Dim od As Workbook, nod As Workbook
Set od = ThisWorkbook
Application.ScreenUpdating = False
    Application.DisplayAlerts = False
'Copy data that you want to save
Muko = Worksheets("Sayfa1").Range("H1")
od.Worksheets("Sayfa1").Range("A2:F9999").Select
    Selection.Copy



' Add a new workbook
Set nod = Workbooks.Add

nod.Worksheets(1).Range("A1").PasteSpecial
ActiveCell.CurrentRegion.EntireColumn.AutoFit

'Save the new workbook
nod.SaveAs od.Path & "\" & Muko & " " & "Satış" & ".xlsx"

Application.DisplayAlerts = True
nod.Close True
Application.ScreenUpdating = True
End Sub

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin.

Private Sub CommandButton2_Click()
    Dim DosyaAdi As String
    DosyaAdi = ThisWorkbook.Worksheets("Sayfa1").Range("H1")
    ThisWorkbook.Worksheets("Sayfa1").Copy
    Application.DisplayAlerts = True
    ActiveWorkbook.Close True, ThisWorkbook.Path & "\" & DosyaAdi & " " & "Satış" & ".xlsx"
    Application.ScreenUpdating = True
End Sub

 

[mukoli]

Hocam çalıştı fakat çalıştırdıgımda aşagıdaki özellikler makro içermeyen kitaba kaydedilmez diye uyarı veriyor makrosuz normal excel olarak kaydetme l-olurmu

 

[Muzaffer Ali]

Dosyanızı ekleyin kontrol edeyim.

 

[mukoli]

ekliyorum hemen hocam

 

[mukoli]

ekledim hocam

 

[Muzaffer Ali]

Eklediğiniz dosyada Module2 de bulunan CommandButton2_Click kodlarını çalıştırdım makro içerme ile ilgili herhangi bir uyarı gelmedi.
Çünkü sayfanın kod sayfasında herhangi bir kod yok.

Ama sizin orijinal dosyanızda yani makro içerme uyarısı veren dosyanızda sayfanın kod kısmında kod var.
Bu kodları inceleyip mümkünse bir modüle aktarmak istedim. Ama siz sayfadaki kodları silerek dosyayı buraya eklediğiniz için yardımcı olamıyorum.

Sizin çalıştığınız dosya farklı bana gönderdiğiniz dosya farklı olunca sorunları bulmak, çözmek mümkün olmuyor.
Bundan sonraki sorularınızda eklediğiniz dosyalarınızın orijinali ile bire bir aynı olmasına dikkat edin.

Herhangi bir hata ve uyarı vermediğine göre son gönderdiğiniz dosya ile çalışabilirsiniz.