İstenen sayfaları Tek parça olarak PDF yapmak

[halit3]

Dosyadaki istenen sayfaları veya istenen bölümleri Tek dosya olarak PDF yapmak için kodları bir altdaki mesajıma ekliyorum. Kodların çalışması için ekli resimdeki gibi tablonuz olmalı G,H sütundaki hücreler dolu olmalı seçenek düğmesi ile seçilmiş olanlar için PDF dosyası oluşturuyor.




Kodun çalışması için aşağıdaki linkdeki dosya veya buraya eklediğim dosya bilgisayarınızda yüklü olması lazım.

not:kodun çalışması için ofisin sürümünün 2007 ve üzeri olması gerekiyor.

http://www.excel.web.tr/f48/pdf-kaydetme-yeri-secme-t89545.html#post488109

 

[halit3]

Kodlar:

Sub Nesneleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If
Next Picture

End Sub

Sub Nesneleriekle()

On Error Resume Next
Set s1 = Sheets(ActiveSheet.Name)
For r = 1 To s1.Shapes.Count
If TypeName(s1.Shapes(r).OLEFormat.Object) = "CheckBox" Then
a = MsgBox("Nesneler mevcut yeniden nesneleri oluşturmak istiyorsanız" & Chr(10) & Chr(10) & _
"Nesneleri sil seçeneğine tıkladıktan sonra yeniden deneyiniz.", vbInformation, " U Y A R I ")
Exit Sub
End If
Next

sut = "c"
For r = 2 To s1.Cells(Rows.Count, "b").End(3).Row  'kisi_sayisi + 1
If s1.Cells(r, "b").Value <> "" Then
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name
'yer1 = Selection.ShapeRange.AlternativeText
s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(r, sut).Top + 4 ' + say
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(r, sut).Left + 4
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(r, sut).Height - 8
s1.Shapes(yer).OLEFormat.Object.Width = 10 's1.Cells(r, sut).Width - 4
s1.Shapes(yer).OLEFormat.Object.Characters.Text = "" ' Cells(r, "u").Value
End If
Next r
'sh.Range("A1").Select
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "

End Sub

Sub hepsinisec()
On Error Resume Next

Dim Picture As Object
Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Picture.BottomRightCell.Column = 3 Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
End If
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Sub hepsinibirak()
On Error Resume Next

Dim Picture As Object
Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Picture.BottomRightCell.Column = 3 Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Sub tobloları_pdf_yap()


Range("D2:F50").ClearContents

Application.ScreenUpdating = False
Application.DisplayAlerts = False

sat = 2
For i = 1 To Sheets.Count
Cells(sat, "d").Value = Sheets(i).Name
sat = sat + 1
Next i

son = 0
For j = 2 To Cells(Rows.Count, "g").End(3).Row
Cells(j, "e").Value = "Bu " & Cells(j, "g").Value & " sayfası yok"
aranan = "" & Cells(j, "g").Value & ""
For i = 1 To Sheets.Count
If aranan = Sheets(i).Name Then
Cells(j, "e").Value = "var"
Cells(j, "f").Value = ""
son = 1
Exit For
End If
Next i
Next j

If son = 0 Then MsgBox "Yazmış olduğunuz sayfa isimleri dosyada mevcut değil", vbInformation, " U Y A R I ": Exit Sub
Dim Picture As Object

For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then

say6 = Picture.BottomRightCell.Row
Cells(say6, "f").Value = "Seçilmedi"
If ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn Then
say3 = Picture.BottomRightCell.Row
ActiveSheet.Cells(say3, "f") = "Evet"
End If
End If
Next Picture


dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set s1 = ThisWorkbook.Sheets(Sayfa_Adı)
yeni_dosya_adı = ActiveWorkbook.Name
For i = 2 To ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, "g").End(3).Row
sayfa = "" & ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "g").Value & ""

If ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "f").Value = "Evet" And ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "e").Value = "var" Then
say4 = say4 + 1

If say4 = 1 Then
ThisWorkbook.Sheets(sayfa).Copy
GoTo atla
Else
ThisWorkbook.Sheets(sayfa).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
End If
atla:

ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = "$a$1"
ActiveSheet.PageSetup.PrintArea = s1.Cells(i, "h")

ActiveWindow.View = xlPageBreakPreview
'On Error Resume Next
'MsgBox ActiveSheet.VPageBreaks.Count
If ActiveSheet.VPageBreaks.Count > 0 Then
ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
End If

End If
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:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveWorkbook.Close False
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

 

[halit3]

Bu dosyada birazcık farklı oldu



kodlar:

Sub Nesneleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If
Next Picture

End Sub

Sub Nesneleriekle()

On Error Resume Next
Set s1 = Sheets(ActiveSheet.Name)
For r = 1 To s1.Shapes.Count
If TypeName(s1.Shapes(r).OLEFormat.Object) = "CheckBox" Then
a = MsgBox("Nesneler mevcut yeniden nesneleri oluşturmak istiyorsanız" & Chr(10) & Chr(10) & _
"Nesneleri sil seçeneğine tıkladıktan sonra yeniden deneyiniz.", vbInformation, " U Y A R I ")
Exit Sub
End If
Next

sut = "b"
For r = 2 To s1.Cells(Rows.Count, "a").End(3).Row  'kisi_sayisi + 1
If s1.Cells(r, "a").Value <> "" Then
yer = s1.CheckBoxes.Add(1, 1, 1, 1).Name
'yer1 = Selection.ShapeRange.AlternativeText
s1.Shapes(yer).OLEFormat.Object.Top = s1.Cells(r, sut).Top + 4 ' + say
s1.Shapes(yer).OLEFormat.Object.Left = s1.Cells(r, sut).Left + 4
s1.Shapes(yer).OLEFormat.Object.Height = s1.Cells(r, sut).Height - 8
s1.Shapes(yer).OLEFormat.Object.Width = 10 's1.Cells(r, sut).Width - 4
s1.Shapes(yer).OLEFormat.Object.Characters.Text = "" ' Cells(r, "u").Value
End If
Next r
'sh.Range("A1").Select
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "

End Sub

Sub hepsinisec()
On Error Resume Next

Dim Picture As Object
Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Picture.BottomRightCell.Column = 2 Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
End If
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Sub hepsinibirak()
On Error Resume Next

Dim Picture As Object
Set s1 = Sheets(ActiveSheet.Name)
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If Picture.BottomRightCell.Column = 2 Then
s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Sub tobloları_pdf_yap()


Range("c2:F50").ClearContents

Application.ScreenUpdating = False
Application.DisplayAlerts = False

sat = 2
For i = 1 To Sheets.Count
Cells(sat, "e").Value = Sheets(i).Name
sat = sat + 1
Next i

son = 0
son1 = 0
For j = 2 To Cells(Rows.Count, "g").End(3).Row
Cells(j, "c").Value = "Bu " & Cells(j, "g").Value & " sayfası yok"
aranan = "" & Cells(j, "g").Value & ""
For i = 1 To Sheets.Count
If aranan = Sheets(i).Name Then
Cells(j, "c").Value = "var"
Cells(j, "f").Value = ""
son = 1
Exit For
End If
Next i
Next j

If son = 0 Then MsgBox "Yazmış olduğunuz sayfa isimleri dosyada mevcut değil", vbInformation, " U Y A R I ": Exit Sub
Dim Picture As Object

For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then

say6 = Picture.BottomRightCell.Row
Cells(say6, "f").Value = "Seçilmedi"
If ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn Then
say3 = Picture.BottomRightCell.Row
ActiveSheet.Cells(say3, "f") = "Evet"
End If
End If
Next Picture


dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set s1 = ThisWorkbook.Sheets(Sayfa_Adı)
yeni_dosya_adı = ActiveWorkbook.Name
For i = 2 To ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, "g").End(3).Row
sayfa = "" & ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "g").Value & ""




If ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "f").Value = "Evet" And ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, "c").Value = "var" Then

s1.Cells(i, "d") = "hücre adresi yanlış yazılmış"
yer = s1.Cells(i, "h")


If IsNumeric(yer) = True Then GoTo atla2

If yer = emtpy Then GoTo atla2
deg1 = Split(yer, ":")
If UBound(deg1) > 0 Then
If Left(deg1(0), 1) = Right(deg1(0), 1) Then GoTo atla2
If Left(deg1(1), 1) = Right(deg1(1), 1) Then GoTo atla2
If IsNumeric(Left(deg1(0), 1)) = True Or IsNumeric(Right(deg1(0), 1)) = False Then GoTo atla2
If IsNumeric(Left(deg1(1), 1)) = True Or IsNumeric(Right(deg1(1), 1)) = False Then GoTo atla2

If IsNumeric(Left(deg1(0), 1)) = True And IsNumeric(Right(deg1(0), 1)) = True Then GoTo atla2
If IsNumeric(Left(deg1(1), 1)) = True And IsNumeric(Right(deg1(1), 1)) = True Then GoTo atla2

If IsNumeric(Left(deg1(0), 1)) = False And IsNumeric(Right(deg1(0), 1)) = False Then GoTo atla2
If IsNumeric(Left(deg1(1), 1)) = False And IsNumeric(Right(deg1(1), 1)) = False Then GoTo atla2


'MsgBox Left(deg1(0), 1)
'MsgBox Right(deg1(0), 1)

'MsgBox Left(deg1(1), 1)
'MsgBox Right(deg1(1), 1)
If deg1(0) = emtpy Then GoTo atla2
If deg1(1) = emtpy Then GoTo atla2
Else
'GoTo atla2
End If

son1 = son1 + 1

say4 = say4 + 1

If say4 = 1 Then
ThisWorkbook.Sheets(sayfa).Copy
GoTo atla
Else
ThisWorkbook.Sheets(sayfa).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
End If
atla:

ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = "$a$1"
'On Error Resume Next

ActiveSheet.PageSetup.PrintArea = s1.Cells(i, "h")

ActiveWindow.View = xlPageBreakPreview
'On Error Resume Next
'MsgBox ActiveSheet.VPageBreaks.Count
If ActiveSheet.VPageBreaks.Count > 0 Then
ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
End If

s1.Cells(i, "d") = ""

atla2:

End If
Next i
If son1 = 0 Then
MsgBox "Hücre adresleri ya yanlış yada hiç hücre adresi yok", vbInformation, " U Y A R I "

Else

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

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

 

[halit3]

Bu kod da birazcık farklı bir uygulama Userform5 için

yeni bir userform oluşturun içine de

1 adet ListBox1 nesnesi
1 adet CheckBox1 nesnesi
1 adet CommandButton1 nesnesi

ekeleyin ve kodu çalıştırın.

Private Sub CheckBox1_Click()
Dim i As Integer
For i = 1 To ListBox1.ListCount
ListBox1.Selected(i - 1) = CheckBox1.Value
Next
End Sub


Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False


say1 = 0

Dim i As Integer
son = 0
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
Exit For
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If


For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then

say1 = say1 + 1
If say1 = 1 Then
ThisWorkbook.Sheets(ListBox1.List(i - 1)).Copy

ActiveSheet.DrawingObjects.Delete
Else
ThisWorkbook.Sheets(ListBox1.List(i - 1)).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
ActiveSheet.DrawingObjects.Delete

End If

End If
Next


If say1 > 0 Then
ActiveWorkbook.Worksheets.Select

yol = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).SubFolders.Count + 1

ad = ThisWorkbook.Path & "\pdf dosyası " & yol
If CreateObject("Scripting.FileSystemObject").FolderExists(ad) = False Then
MkDir ad
End If

say = CreateObject("Scripting.FileSystemObject").getfolder(ad).Files.Count + 1

ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ad & "\pdf dosyası " & say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveWorkbook.Close False
End If
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Private Sub UserForm_Initialize()
ListBox1.ListStyle = 1
ListBox1.MultiSelect = 1
For i = 1 To ActiveWorkbook.Sheets.Count
ListBox1.AddItem Sheets(i).Name

Next i
End Sub

 

[baydeniro]

Bu dosyada birazcık farklı oldu



[/CODE]

Üstad 3. mesajdaki kodları hangi sırayla çalıştırmamız gerektiği hakkında bilgi paylaşabilir misin ?

 

[halit3]

Bu kod da farklı
A sutununa sayfa ismi
B sutununa hücre adresi
C sutununa büyük (X) işareti
yazılarak kod çalıştırılır.
kod

Sub pdf_yap()

sut = 1
Range(Cells(2, sut + 3), Cells(Rows.Count, sut + 3)).ClearContents

Application.ScreenUpdating = False
Application.DisplayAlerts = False

yer = ActiveSheet.Name

son = 0
For j = 2 To Cells(Rows.Count, sut).End(3).Row
Cells(j, sut + 3).Value = Cells(j, sut).Value & " sayfası yok"
aranan = "" & Cells(j, sut).Value & ""
'Cells(j, sut + 4).Value = "yok"
For i = 1 To Sheets.Count
If aranan = Sheets(i).Name Then
Cells(j, sut + 3).Value = "var"
'Cells(j, sut + 4).Value = Sheets(i).Name
son = 1
Exit For
End If
Next i
Next j

If son = 0 Then MsgBox "Yazmış olduğunuz sayfa isimleri dosyada mevcut değil", vbInformation, " U Y A R I ": Exit Sub

Dosya_Adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set s1 = ThisWorkbook.Sheets(Sayfa_Adı)
yeni_dosya_adı = ActiveWorkbook.Name
For i = 2 To ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, sut).End(3).Row
sayfa = "" & ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, sut).Value & ""

If ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, sut + 2).Value = "X" And ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, sut + 3).Value = "var" Then
say4 = say4 + 1

If say4 = 1 Then
ThisWorkbook.Sheets(sayfa).Copy
GoTo atla
Else
ThisWorkbook.Sheets(sayfa).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
End If
atla:



ActiveWorkbook.ActiveSheet.PageSetup.PrintArea = ""
ActiveWorkbook.ActiveSheet.PageSetup.PrintArea = "$a$1"
ActiveWorkbook.ActiveSheet.PageSetup.PrintArea = s1.Cells(i, sut + 1)

ActiveWindow.View = xlPageBreakPreview
'On Error Resume Next
'MsgBox ActiveSheet.VPageBreaks.Count
If ActiveWorkbook.ActiveSheet.VPageBreaks.Count > 0 Then
ActiveWorkbook.ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
End If

End If
Next i

If say4 > 0 Then

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:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ActiveWorkbook.Close False
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
Else
MsgBox "sayfa seçilmedi"
End If

Sheets(yer).Select
End Sub

 

[tamer42]

Bu kod da farklı
A sutununa sayfa ismi
B sutununa hücre adresi
C sutununa büyük (X) işareti
yazılarak kod çalıştırılır.
kod

Sub pdf_yap()

sut = 1
Range(Cells(2, sut + 3), Cells(Rows.Count, sut + 3)).ClearContents

Application.ScreenUpdating = False
Application.DisplayAlerts = False

yer = ActiveSheet.Name

son = 0
For j = 2 To Cells(Rows.Count, sut).End(3).Row
Cells(j, sut + 3).Value = Cells(j, sut).Value & " sayfası yok"
aranan = "" & Cells(j, sut).Value & ""
'Cells(j, sut + 4).Value = "yok"
For i = 1 To Sheets.Count
If aranan = Sheets(i).Name Then
Cells(j, sut + 3).Value = "var"
'Cells(j, sut + 4).Value = Sheets(i).Name
son = 1
Exit For
End If
Next i
Next j

If son = 0 Then MsgBox "Yazmış olduğunuz sayfa isimleri dosyada mevcut değil", vbInformation, " U Y A R I ": Exit Sub

Dosya_Adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set s1 = ThisWorkbook.Sheets(Sayfa_Adı)
yeni_dosya_adı = ActiveWorkbook.Name
For i = 2 To ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, sut).End(3).Row
sayfa = "" & ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, sut).Value & ""

If ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, sut + 2).Value = "X" And ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, sut + 3).Value = "var" Then
say4 = say4 + 1

If say4 = 1 Then
ThisWorkbook.Sheets(sayfa).Copy
GoTo atla
Else
ThisWorkbook.Sheets(sayfa).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
End If
atla:



ActiveWorkbook.ActiveSheet.PageSetup.PrintArea = ""
ActiveWorkbook.ActiveSheet.PageSetup.PrintArea = "$a$1"
ActiveWorkbook.ActiveSheet.PageSetup.PrintArea = s1.Cells(i, sut + 1)

ActiveWindow.View = xlPageBreakPreview
'On Error Resume Next
'MsgBox ActiveSheet.VPageBreaks.Count
If ActiveWorkbook.ActiveSheet.VPageBreaks.Count > 0 Then
ActiveWorkbook.ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
End If

End If
Next i

If say4 > 0 Then

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:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ActiveWorkbook.Close False
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
Else
MsgBox "sayfa seçilmedi"
End If

Sheets(yer).Select
End Sub

Merhaba,
Excel dosyasında sayfalar içerisine renkli bir resim eklediği zaman PDF dosyasında siyah beyaz olarak oluşmaktadır.

bu sorunu nasıl aşabiliriz?

Teşekkürler.
İyi Çalışmalar.

 

[halit3]

Ben sayfaya çiçek resmi ekledim onuda pdf dosyası yaptım resimler nasıl ise öyle pdf oluyor.

 

[tamer42]

Ben sayfaya çiçek resmi ekledim onuda pdf dosyası yaptım resimler nasıl ise öyle pdf oluyor.

Sn Halit sorun Printer ayarlarından olabilir mi?
Tanımlı Yazıcı siyah beyaz olmasından dolayı;

iyi çalışmalar.

 

[halit3]

Bu konuda birşey diyemiyeceğim
ancak söylediğiniz gibi oluyorsa sanal bir yazıcı kurun varsayılan yazıcı yapın birde öyle deneyiniz.

 

[tamer42]

Bu konuda birşey diyemiyeceğim
ancak söylediğiniz gibi oluyorsa sanal bir yazıcı kurun varsayılan yazıcı yapın birde öyle deneyiniz.

Sn Halit başka bir sıkıntı olmalı, çünkü excel dosyada mevcut bulunan şekiller PDF' te renkli çıkarken, benim excel dosyasına yeni eklediklerim PDF' te siyah beyaz oluyor.

iyi Çalışşmalar.

 

[tamer42]

Sn Halit başka bir sıkıntı olmalı, çünkü excel dosyada mevcut bulunan şekiller PDF' te renkli çıkarken, benim excel dosyasına yeni eklediklerim PDF' te siyah beyaz oluyor.

iyi Çalışmalar.

Tekrar merhaba,
sistematik bir sorun var galiba;
Aynı resim dosyasını Farklı Kaydet >>> PDF yoluyla;

Word dosyasından PDF' e çevirirken renkli oluşurken, aynı işlemi Excel dosyasından yaparken siyah-beyaz oluşuyor.
Ekli dosyalarda görülmektedir.

iyi akşamlar.