[Yardım]  Dosya içinden resim çağırmak

Excel hakkındaki soru ya da paylaşımlarınıza kategori bulamadıysanız bu alana yazabilirsiniz.

Dosya içinden resim çağırmak

İleti#1)  caramon13 » 28 Haz 2020 09:50

Merhaba

Ekteki çalışma dosyam için yardım rica ediyorum. Macro dış klasörden resim çağırarak çalışıyor. Fakat bazen görsellerin asıllarına erişemiyorum. Dosya içine gömülü liste şeklinde gönderiyorlar. Ekteki gibi aynı excel içinde başka bir sheet'ten diğer bir sheet'e macro ile resim çağırmak mümkün mü? Birde macro üst addan alta resim mantığındaydı. Bu mantığı altta ad üste resim mantığına getirebilir miyiz? Destek veren arkadaşlara şimdiden teşekkür eder hayırlı forumlar dilerim.

Saygılarımla
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
caramon13
 
Kayıt: 27 May 2015 12:53
Meslek: yönetici
Yaş: 39
İleti: 3
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul/bahçelievler

Cevap: Dosya içinden resim çağırmak

İleti#2)  Miraç CAN » 29 Haz 2020 08:12

Tekrar merhaba,
Kod: Tümünü seç
Sub PicturesCopy()
Dim Resim As Object, iSyf$, ResimAdı$
Dim Sayfa As Worksheet, Syf_Kont As Boolean, satır%, sütun%
rtrn: iSyf = InputBox("Resimlerin bulunduğu sayfa adını yazın...", "Sayfa Seç", ActiveSheet.Name)
If iSyf = Empty Then Exit Sub
For Each Sayfa In Worksheets
    If Sayfa.Name Like iSyf Then Syf_Kont = True: Exit For
Next Sayfa
If Not Syf_Kont Then MsgBox "Sayfa adı hatalı/yanlış", vbOKOnly + vbExclamation, "Uyarı": GoTo rtrn
Set Sayfa = Sheets(iSyf)
For Each Resim In ActiveSheet.Shapes
    If Not Intersect(Resim.TopLeftCell, Range("B2:XFD1048576")) Is Nothing And Resim.Type = 13 Then
        Resim.Delete
    End If
Next Resim
For satır = 3 To Cells(Rows.Count, 2).End(3).Row Step 9
    If Cells(satır, Columns.Count).End(1).Column > 3 Then Range(Cells(satır, 3), Cells(satır, Columns.Count).End(1)).ClearContents
    For sütun = 3 To Cells(satır + 1, Columns.Count).End(1).Column
        On Error Resume Next
        If IsError(Application.Match(Cells(satır + 1, sütun), Sayfa.Range("B:B"), 0)) Then
            Cells(satır, sütun) = "Bulunamadı.": Err.Clear
        Else
            Sayfa.Cells(Application.Match(Cells(satır + 1, sütun), Sayfa.Range("B:B"), 0), 3).Copy
            Cells(satır, sütun).Activate: ActiveSheet.Paste: ActiveCell.ClearContents
        For Each Resim In ActiveSheet.Shapes
            ResimAdı = Empty
            If Not Intersect(Resim.TopLeftCell, Cells(satır, sütun)) Is Nothing Then
                If Resim.Type = 13 Then ResimAdı = Resim.Name: Exit For
            End If
        Next Resim
            With ActiveSheet.Pictures(ResimAdı)
                .ShapeRange.LockAspectRatio = msoFalse
                .Top = Cells(satır, sütun).Top
                .Left = Cells(satır, sütun).Left
                .Height = Cells(satır, sütun).Height
                .Width = Cells(satır, sütun).Width
            End With
        End If
    Next sütun, satır
End Sub
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 543
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya\Adana


Forum Diğer Excel İşlemleri

Online Kullanıcılar

Bu forumu görüntüleyenler: AhrefsBot ve 1 misafir

Bumerang - Yazarkafe