KOD ÇALIŞINCA RESİMLER KAYIYOR

[karakaçan]

Arkadaşlar sorumu ekteki dosyada yazdım. Yardımcı olabilecek varsa sevinirim. forumlarda benzer sorular ve çözümler var ama altın üye olmadığım için dosya indiremiyorum. Kusura bakmayın

https://dosya.co/9u9d07jscsba/İSME_GÖRE_SINAV.xlsm.html

 

[karakaçan]

çözüm sunabilecek kimse var mı acaba?

 

[ÖmerBey]

Merhaba,
İlk bahsettiğiniz problem ben de olmadı. Mevcut dosyanızdaki kodu çalıştırdım ve düzgün sonuç aldım. Bir de başka bir bilgisayarda deneyiniz.
İkinci isteğiniz için de şuradaki programı kullanabilirsiniz. Sadece pdf birleştirmek için üretilmiş ücretsiz, hızlı ve basit bir program.
İyi çalışmalar...

 

[halit3]

Pdf dosyası yapmak için bu kodu bir dene
not kodun çalışması için SINAV KAĞIDI sayfasında S1 Hücresinde sayı olmalı ve sıfırdan büyük olmalı

Sub tobloları_pdf_yap()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sayfa_Adı = ActiveSheet.Name
Set S1 = ThisWorkbook.Sheets(Sayfa_Adı)

For i = 1 To ThisWorkbook.Sheets(Sayfa_Adı).Cells(1, "s").Value

If i = 1 Then
ThisWorkbook.Sheets(Sayfa_Adı).Copy
'ActiveSheet.DrawingObjects.Delete
Else
ThisWorkbook.Sheets(Sayfa_Adı).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
'ActiveSheet.DrawingObjects.Delete
End If

say = 5
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
say = say + 1
If Picture.Type = 12 Or Picture.Type = 1 Or Picture.Type = 8 Then
'If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture

Next i

ActiveWorkbook.Worksheets.Select
Dim yol As String
Application.DisplayAlerts = False
yol = ThisWorkbook.Path
Say2 = CreateObject("Scripting.FileSystemObject").getfolder(yol).Files.Count + 1
ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol & "\pdf dosyası " & Say2 & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
ActiveWorkbook.Close False

Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

 

[karakaçan]

Teşekkür ederim sağ olun hayrlı günler

 

[halit3]

Teşekkür ederim sağ olun hayrlı günler

Teşekkürler iyi çalışmalar