Soru Kapalı exceldeki resimleri aktarma?

[mkarakas_58]

Merhabalar,

Bir klasör içindeki kapalı excel dosyalarının içindeki verileri aşağıdaki kodlarla birleştiriyorum. Sorunum bu kapalı dosyalarının her birinde J3 hücresinde firmaların logoları bulunmakta.(resim formatında)

Ben bu logolarıda getirmek istiyorum.

Konu hakkında yardımcı olursanız sevinirim.

Sub aktar59()
Dim sat1 As Long, i As Long, sut As Byte, yol As String
Dim dosya As String, sat2 As Long, sh As Worksheet
Application.ScreenUpdating = False
sat1 = 3
yol = ThisWorkbook.Path & "\Talepler\"
With Sheets("Firma Giriş")
    .Range("A3:K" & Rows.Count).ClearContents
    dosya = Dir(yol & "*.xls")
    Do While dosya <> ""
        If Workbooks.Open(yol & dosya).ReadOnly = True Then Workbooks(dosya).Close False
            Set sh = ActiveWorkbook.Sheets("Firma Giriş")
            sat2 = sh.Cells(Rows.Count, "C").End(xlUp).Row
            If sat2 > 2 Then
                sh.Range("A3:K" & sat2).Copy
                .Range("A" & sat1).PasteSpecial
                Application.CutCopyMode = False
                Set sh = Nothing
            End If
        dosya = Dir
        ActiveWorkbook.Close False
        sat1 = .Cells(Rows.Count, "C").End(xlUp).Row + 1
    Loop
End With
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbOKOnly + vbInformation
End Sub

 

[mkarakas_58]

Set yeniResim = hedefSh.Pictures.Paste

Bu satırda kalıyor hocam. Ayrıca klasördeki ilk dosyayı açılıyor.

 

[muhasebeciyiz]

Sub aktar59()
    Dim sat1 As Long, i As Long, sut As Byte, yol As String
    Dim dosya As String, sat2 As Long, sh As Worksheet
    Dim kaynakSh As Worksheet, hedefSh As Worksheet
    Dim kaynakResim As Shape, yeniResim As Object
    Dim resimAd As String
    Application.ScreenUpdating = False
    sat1 = 3
    yol = ThisWorkbook.Path & "\Talepler\"
    Set hedefSh = ThisWorkbook.Sheets("Firma Giriş")
    
    ' Hedef sayfanın içeriğini temizle
    hedefSh.Range("A3:K" & Rows.Count).ClearContents
    
    dosya = Dir(yol & "*.xls") 
    
    Do While dosya <> ""
        ' Dosyayı aç
        Dim wb As Workbook
        Set wb = Workbooks.Open(yol & dosya, ReadOnly:=True)
        Set kaynakSh = wb.Sheets("Firma Giriş")
        
        sat2 = kaynakSh.Cells(Rows.Count, "C").End(xlUp).Row       
        
        If sat2 > 2 Then
            kaynakSh.Range("A3:K" & sat2).Copy
            hedefSh.Range("A" & sat1).PasteSpecial
            Application.CutCopyMode = False           
            
            For Each kaynakResim In kaynakSh.Shapes
                If Not Intersect(kaynakResim.TopLeftCell, kaynakSh.Range("A3:K" & sat2)) Is Nothing Then
                    ' Resmi yeni sayfaya kopyala
                    resimAd = kaynakResim.Name & "_copy"
                    ' Resmi hedef sayfaya ekle
                    Set yeniResim = hedefSh.Shapes.AddPicture( _
                        FileName:=kaynakResim.LinkFormat.SourceFullName, _
                        LinkToFile:=msoFalse, _
                        SaveWithDocument:=msoTrue, _
                        Left:=hedefSh.Range("A" & sat1).Left, _
                        Top:=hedefSh.Range("A" & sat1).Top, _
                        Width:=-1, _
                        Height:=-1 _
                    )
                    yeniResim.Name = resimAd
                End If
            Next kaynakResim
            
            sat1 = hedefSh.Cells(Rows.Count, "C").End(xlUp).Row + 1
        End If       
        
        wb.Close False
        
        dosya = Dir  ' Bir sonraki dosyayı al
    Loop
    
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı.", vbOKOnly + vbInformation
End Sub

Tekrar Deneyiniz

 

[mkarakas_58]

Hocam ekte dosyalar bulunmaktadır. Klasörün içindeki verileri alıyorum. Ama resimleri alamıyorum.

Excel Güncelleme.zip

drive.google.com

 

[muhasebeciyiz]

Talepler isimli klasör altındaki dosyalarda resimler yüklenmiş olacak

Bu dosyanızada önce birleştir butonuna basın bilgiler gelsin
Sonrasında logo yükle butonuna basın logolar gelmektedir.

 

[mkarakas_58]

Talepler isimli klasör altındaki dosyalarda resimler yüklenmiş olacak

Bu dosyanızada önce birleştir butonuna basın bilgiler gelsin
Sonrasında logo yükle butonuna basın logolar gelmektedir.

Evet hocam geldi ama dosya konumundan geliyor. Amacım klasör içindeki kapalı dosyalardaki resimleri almak. Her personel dosyayı oluşturup bana excel olarak gönderiyor. Bende aynı formatta birleştirme yapmam lazım. Resimlerin dosya yolu bende pcde bulunmamaktadır.