Çözüldü Kapalı Dosyadan Resim Alma

okan32 · 9 Kasım 2018

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

turist · 9 Kasım 2018

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

okan32 · 9 Kasım 2018

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

İ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")

turist · 9 Kasım 2018

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

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

şeklinde deneyin.

turist · 9 Kasım 2018

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.

okan32 · 9 Kasım 2018

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.

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

halit3 · 9 Kasım 2018

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

okan32 · 9 Kasım 2018

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

Çok Teşekkür Ederim Halit Bey kod sıkıntısız çalıştı. Sorunum çözüldü

halit3 · 9 Kasım 2018

okan32' Alıntı:
Çok Teşekkür Ederim Halit Bey kod sıkıntısız çalıştı. Sorunum çözüldü

Teşekkürler iyi çalışmalar

turist · 9 Kasım 2018

Dosyanız eklidir.

turist · 9 Kasım 2018

okan32' Alıntı:
İLGİLİ KOD SATIRINI DEĞİŞTİRDİM TÜM VERİLERİ ALIYOR AMA FOTOLARI YİNE ALMADI SAYIN TURİST

#10. MESAJDA EKLENEN DOSYAYA BAKIN.

okan32 · 9 Kasım 2018

Halit Bey özür diliyorum. Fotoğrafların L2 den itibaren sıralanmasını istiyorum. Yapmaya çalıştım ama yapamadım.

halit3 · 9 Kasım 2018

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

okan32 · 9 Kasım 2018

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

Tamam halit bey sağolun

Çözüldü Kapalı Dosyadan Resim Alma

okan32

turist

Destek Ekibi

okan32

Ekli dosyalar

turist

Destek Ekibi

turist

Destek Ekibi

okan32

halit3

Uzman

okan32

halit3

Uzman

turist

Destek Ekibi

Ekli dosyalar

turist

Destek Ekibi

okan32

halit3

Uzman

okan32