• DİKKAT

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

Çözüldü Kapalı Dosyadan Resim Alma

  • Konbuyu başlatan Konbuyu başlatan okan32
  • Başlangıç tarihi Başlangıç tarihi
okan32

okan32

Katılım
12 Mayıs 2016
Mesajlar
386
Excel Vers. ve Dili
Ofis 2019- 32 Bit - Türkçe
S.A Arkadaşlar aşağıdaki kodla kapalı olan Personel rapor dosyasından verileri başarılı bir şekilde çekiyorum. Fakat L sütunundaki fotoğraflar gelmiyor. Fotoğraflarında gelmesi için kodllarda nasıl bir düzenleme yapabiliriz. Yardımlarınız bekliyorum şimdiden teşekkür ederim.

Kod: 
Sub veri_çek()
Dim KTP As Workbook, ASİ As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, YOL As String
Dim HCR As Variant
Application.ScreenUpdating = False
Set ASİ = CreateObject("Excel.Application")
ASİ.Visible = False
YOL = ThisWorkbook.Path & "\"
A1 = ActiveWorkbook.Name
Set A1S1 = Workbooks(A1).Sheets("Sayfa1")
A2 = "Personel Rapor.xls"
HCR = ActiveCell.Address
Set KTP = ASİ.Workbooks.Open(YOL & A2)
Set A2S2 = KTP.Sheets("Personel Rapor")
A2S2.Range("A3:L50").Copy
A1S1.Range("A1").PasteSpecial (xlPasteValues)
KTP.Save: ASİ.Quit
Range(HCR).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "Ali KOÇ"
End Sub
 
Aşağıdaki gibi deneyiniz.
Rich (BB code): 
Sub veri_çek()
Dim KTP As Workbook, ASİ As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, YOL As String
Dim HCR As Variant
Application.ScreenUpdating = False
Set ASİ = CreateObject("Excel.Application")
ASİ.Visible = False
YOL = ThisWorkbook.Path & "\"
A1 = ActiveWorkbook.Name
Set A1S1 = Workbooks(A1).Sheets("Sayfa1")
A2 = "Personel Rapor.xls"
HCR = ActiveCell.Address
Set KTP = ASİ.Workbooks.Open(YOL & A2)
Set A2S2 = KTP.Sheets("Personel Rapor")
A2S2.Range("A3:L50").Copy A1S1.Range("A1")
A1S1.Range("A1:L50").Value=A1S1.Range("A1:L50").Value
KTP.Save: ASİ.Quit
Range(HCR).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "Ali KOÇ"
End Sub
 
turist' Alıntı:
Aşağıdaki gibi deneyiniz.
Rich (BB code): 
Sub veri_çek()
Dim KTP As Workbook, ASİ As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, YOL As String
Dim HCR As Variant
Application.ScreenUpdating = False
Set ASİ = CreateObject("Excel.Application")
ASİ.Visible = False
YOL = ThisWorkbook.Path & "\"
A1 = ActiveWorkbook.Name
Set A1S1 = Workbooks(A1).Sheets("Sayfa1")
A2 = "Personel Rapor.xls"
HCR = ActiveCell.Address
Set KTP = ASİ.Workbooks.Open(YOL & A2)
Set A2S2 = KTP.Sheets("Personel Rapor")
A2S2.Range("A3:L50").Copy A1S1.Range("A1")
A1S1.Range("A1:L50").Value=A1S1.Range("A1:L50").Value
KTP.Save: ASİ.Quit
Range(HCR).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "Ali KOÇ"
End Sub
Genişletmek için tıkla ...

İlginiz için çok teşekkür ederim sayın Turist alttaki sarıda hata verdi. örnek dosyayıda yükledim
A2S2.Range("A3:L50").Copy A1S1.Range("A1")
 

Ekli dosyalar

A2S2.Range("A3:L50").Copy A1S1.Range("A1") satırını

A2S2.Range("A3:L50").Copy
A1S1.Range("A1").PasteSpecial

şeklinde deneyin.
 
Sonuç vermezse;
A2S2.Range("A3:L50").Copy A1S1.Range("A1") satırını


A2S2.Range("A3:L50").Copy
A1S1.Select
A1S1.Range("A1").Select
A1S1.Paste

Şeklinde deneyin.
 
turist' Alıntı:
Sonuç vermezse;
A2S2.Range("A3:L50").Copy A1S1.Range("A1") satırını


A2S2.Range("A3:L50").Copy
A1S1.Select
A1S1.Range("A1").Select
A1S1.Paste

Şeklinde deneyin.
Genişletmek için tıkla ...

İLGİLİ KOD SATIRINI DEĞİŞTİRDİM TÜM VERİLERİ ALIYOR AMA FOTOLARI YİNE ALMADI SAYIN TURİST
 
Alternatif kod

Rich (BB code): 
Sub veri_çek()
Dim KTP As Workbook, ASİ As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, yol As String
Dim HCR As Variant
Application.ScreenUpdating = False
Set ASİ = CreateObject("Excel.Application")
ASİ.Visible = True
yol = ThisWorkbook.Path & "\"
A1 = ActiveWorkbook.Name
Set A1S1 = Workbooks(A1).Sheets("Sayfa1")
A2 = "Personel Rapor.xls"
HCR = ActiveCell.Address
Set KTP = ASİ.Workbooks.Open(yol & A2)
Set A2S2 = KTP.Sheets("Personel Rapor")
A2S2.Range("A3:L50").Copy
A1S1.Range("A1").PasteSpecial (xlPasteValues)


For Each Picture In A2S2.Shapes
If TypeName(A2S2.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
'sat = Picture.BottomRightCell.Row - 3
sat= Picture.TopLeftCell.Row - 2

A2S2.Shapes(Picture.Name).CopyPicture

ThisWorkbook.Activate
ThisWorkbook.Sheets("Sayfa1").Select
Range("L" & sat).Select
ThisWorkbook.Sheets("Sayfa1").Paste

Set Adres = Sheets("Sayfa1").Range(Sheets("Sayfa1").Cells(sat, 12), Sheets("Sayfa1").Cells(sat, 12))

Selection.Top = Adres.Top + 3
Selection.Left = Adres.Left + 3
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Adres.Height - 4
Selection.ShapeRange.Width = Adres.Width - 4
End If
Next Picture


KTP.Save: ASİ.Quit
Range(HCR).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "Ali"
End Sub
 
Son düzenleme:
halit3' Alıntı:
Alternatif kod

Rich (BB code): 
Sub veri_çek()
Dim KTP As Workbook, ASİ As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, yol As String
Dim HCR As Variant
Application.ScreenUpdating = False
Set ASİ = CreateObject("Excel.Application")
ASİ.Visible = True
yol = ThisWorkbook.Path & "\"
A1 = ActiveWorkbook.Name
Set A1S1 = Workbooks(A1).Sheets("Sayfa1")
A2 = "Personel Rapor.xls"
HCR = ActiveCell.Address
Set KTP = ASİ.Workbooks.Open(yol & A2)
Set A2S2 = KTP.Sheets("Personel Rapor")
A2S2.Range("A3:L50").Copy
A1S1.Range("A1").PasteSpecial (xlPasteValues)


For Each Picture In A2S2.Shapes
If TypeName(A2S2.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
sat = Picture.BottomRightCell.Row - 3
A2S2.Shapes(Picture.Name).CopyPicture

ThisWorkbook.Activate
ThisWorkbook.Sheets("Sayfa1").Select
Range("L" & sat).Select
ThisWorkbook.Sheets("Sayfa1").Paste

Set Adres = Sheets("Sayfa1").Range(Sheets("Sayfa1").Cells(sat, 12), Sheets("Sayfa1").Cells(sat, 12))

Selection.Top = Adres.Top + 3
Selection.Left = Adres.Left + 3
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Adres.Height - 4
Selection.ShapeRange.Width = Adres.Width - 4
End If
Next Picture


KTP.Save: ASİ.Quit
Range(HCR).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "Ali"
End Sub
Genişletmek için tıkla ...

Çok Teşekkür Ederim Halit Bey kod sıkıntısız çalıştı. Sorunum çözüldü
 
Halit Bey özür diliyorum. Fotoğrafların L2 den itibaren sıralanmasını istiyorum. Yapmaya çalıştım ama yapamadım.
 
Kapalı dosyadaki resimler hücrelerin dışına taşmış dolayasıyla satır numarası da bu yüzden fark ediyor.
kodun burasına dikkat edin.
Rich (BB code): 
'sat = Picture.BottomRightCell.Row - 3
sat= Picture.TopLeftCell.Row - 2

3 sayısını azaltın veya arttırın
 
Son düzenleme:
halit3' Alıntı:
Kapalı dosyadaki resimler hücrelerin dışına taşmış dolayasıyla satır numarası da bu yüzden fark ediyor.
kodun burasına dikkat edin.
Rich (BB code): 
sat = Picture.BottomRightCell.Row - 3

3 sayısını azaltın veya arttırın
Genişletmek için tıkla ...
Tamam halit bey sağolun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst