Soru Resmi çağırıp formu doldurup toplu yazdırma

[mcetinkaya65]

Bilgi ve beceri izleme formu isimli bir dosya yaptım. Resimleri aynı çalışmanın içinden resimler adlı sayfadan çekiyor. Resimler arasında aynı satıra gelen resmi çekiyor. Tabi gelen giden personel arasında resimler ile veri sayfasındaki isimler farklı sırada olabiliyor. Listeler ve fotoğraflarda sayı bakımından farklı olabiliyor. Aynı satırı değilde aynı isimli resmi çekmesi mümkün mü?
Topluca formu doldurtup yazdırmamız mümkün mü?

 

[YUSUF44]

Resimlerekle makrosunda Adres2 ile başlayan satırdan önceki sat satırını aşağıdakiyle değiştirin:

sat = WorksheetFunction.Match([E6], Sheets("Resimler").[A1:A100], 0)

 

[YUSUF44]

Topluca yazdırmak için aşağıdaki makroyu kullanabilirsiniz:

Sub yaz()
Set s1 = Sheets("Veriler")
Set s2 = Sheets("Form")
son = s1.Cells(Rows.Count, "B").End(3).Row
For i = 4 To son
    s2.[A1] = i - 3
    s2.PrintOut
Next
End Sub

 

[mcetinkaya65]

sat = WorksheetFunction.Match([E6], Sheets("Resimler").[A1:A100], 0)

Üstad Allah Razı Olsun. İstenilen olmuş.
Fakat veriler sayfasında olan isimden resimler sayfasında isim ve resim yoksa hata veriyor.
Birde toplu yazdırda veriler değişiyor fakat fotoğraflar değişmiyor.

 

[YUSUF44]

Resimlereekle makronuz:

Sub Resimlerekle()
sat1 = 6
sat2 = 13
sut1 = 18
sut2 = 24
Dim Picturer As Object
Set Adres = Range(Cells(sat1, sut1).Address, Cells(sat2, sut2).Address)
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
End If
Next Picture
If WorksheetFunction.CountIf(Sheets("Resimler").[A1:A100], [E6]) > 0 Then
    sat = WorksheetFunction.Match([E6], Sheets("Resimler").[A1:A100], 0)
Else
    'MsgBox "Belirtilen isim Resimler sayfasında bulunamadı", vbInformation
    Exit Sub
End If
Adres2 = Sheets("Resimler").Cells(sat, 2).Address
For Each Picture In Sheets("Resimler").Shapes
If Picture.BottomRightCell.Address = Adres2 Then
Sheets("Resimler").Shapes(Picture.Name).CopyPicture
Range("R6").Select
Sheets("Form").Paste

End If
Next Picture
For Each Picturer In ActiveSheet.Shapes
If Not Intersect(Range(Picturer.TopLeftCell.Address & ":" & Picturer.BottomRightCell.Address), Adres) Is Nothing Then
ad = Picturer.Name
ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width
Range("R6").Select
End If
Next Picturer
End Sub

Yazdırma makrosu:

Sub yaz()
Set s1 = Sheets("Veriler")
Set s2 = Sheets("Form")
son = s1.Cells(Rows.Count, "B").End(3).Row
For i = 4 To son
    s2.[A1] = i - 3
    Call Resimlerekle
    s2.PrintOut
Next
End Sub

 

[mcetinkaya65]

Selamünaleyküm.
Üstad Allah razı olsun.
İlginize bilginize teşekkür ederim.