Tek sayfadaki yazdırma alanındaki sayfalarda istenen sıra ile pdf yapmak, masaüstüne kaydetmek.
Mesaj kutusuna sayfaları gruplayarak girebilirsiniz.
3-5 gibi veya 3,4,5 gibi veya 3-4,1-2 gibi girilmeli.
5-3 gibi bir grubu büyükten küçüğe, tersten girmemeli.
Sayfa gruplandırmalarını anlaması için ek olarak Function ExpandedSeries() kullanıldı
- Kod: Tümünü seç
Sub pdf_Yap_Siralamayi_Degistir()
Dim sh1 As Worksheet, YazVeSil As Worksheet
Dim rng As Range, stcell As String
Dim yol As String, pdfdosya As String
Dim kac As String, spl As Variant
Dim a As Variant, sons As Long, i As Integer
Dim alan As String, isat As String, ssat As String, isut As String, ssut As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo syok
If Len(Worksheets("YazVeSil").Name) > 0 Then Worksheets("YazVeSil").Delete
syok:
Application.DisplayAlerts = True
Set sh1 = Sheets("formüller")
yol = ThisWorkbook.Path
kac = InputBox("Yazdırma Alanı Sırasını Giriniz." & vbLf & vbLf & _
"""" & sh1.Name & """ sekmesinde" & vbLf & _
sh1.HPageBreaks.Count + 1 & " adet yazdırma sayfası tesbit edildi", Title:="Sayfaları Sıralayınız.", Default:="3-4,1,2 gibi")
spl = Split(ExpandedSeries(kac), ", ")
If UBound(spl) = -1 Then Exit Sub
For Each a In spl
If sh1.HPageBreaks.Count + 1 >= a Then
Else
MsgBox "Mümkün olandan fazla sayfa sayısı girildi!", vbInformation
Exit Sub
End If
Next a
alan = sh1.PageSetup.PrintArea
isat = Split(alan, ":")(0)
ssat = Split(alan, ":")(1)
isut = Split(alan, "$")(1)
ssut = Split(ssat, "$")(1)
With ActiveWorkbook
Set YazVeSil = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
ActiveSheet.Name = "YazVeSil"
End With
sons = 1
For i = LBound(spl) To UBound(spl)
Select Case spl(i)
Case 1
from = isat
too = ssut & Split(sh1.HPageBreaks(spl(i)).Location.Address, "$")(2) - 1
sh1.Range(from & ":" & too).Copy
YazVeSil.Cells(sons, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
YazVeSil.Cells(sons, 1).PasteSpecial xlPasteColumnWidths
sons = YazVeSil.Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
Sheets("YazVeSil").HPageBreaks.Add _
before:=Range("" & isut & sons & "")
Case sh1.HPageBreaks.Count + 1
from = isut & Split(sh1.HPageBreaks(spl(i) - 1).Location.Address, "$")(2)
too = ssat
sh1.Range(from & ":" & too).Copy
YazVeSil.Cells(sons, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
YazVeSil.Cells(sons, 1).PasteSpecial xlPasteColumnWidths
sons = YazVeSil.Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
Sheets("YazVeSil").HPageBreaks.Add _
before:=Range("" & isut & sons & "")
Case Else
from = isut & Split(sh1.HPageBreaks(spl(i) - 1).Location.Address, "$")(2)
too = ssut & Split(sh1.HPageBreaks(spl(i)).Location.Address, "$")(2) - 1
sh1.Range(from & ":" & too).Copy
YazVeSil.Cells(sons, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
YazVeSil.Cells(sons, 1).PasteSpecial xlPasteColumnWidths
sons = YazVeSil.Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
Sheets("YazVeSil").HPageBreaks.Add _
before:=Range("" & isut & sons & "")
End Select
Next
pdfdosya = Environ("USERPROFILE") & "\Desktop\" & Sheets("formüller").Range("BI39").Value & ".pdf"
Application.DisplayAlerts = False
Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
stcell = "A1": lcell = rng.Address
ActiveSheet.PageSetup.PrintArea = stcell & ":" & lcell
YazVeSil.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
pdfdosya, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=showAfterSave
YazVeSil.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Pdf dosyası oluşturuldu", vbInformation
End Sub
Function ExpandedSeries(ByVal S As String, Optional Delimiter As String = ", ") As Variant
Dim X As Long, Y As Long, Z As Long
Dim Letter As String, Numbers() As String, Parts() As String
S = Chr$(1) & Replace(Replace(Replace(Replace(Application.Trim(Replace(S, ",", _
" ")), " -", "-"), "- ", "-"), " ", " " & Chr$(1)), "-", "-" & Chr$(1))
Parts = Split(S)
For X = 0 To UBound(Parts)
If Parts(X) Like "*-*" Then
For Z = 1 To InStr(Parts(X), "-") - 1
If IsNumeric(Mid(Parts(X), Z, 1)) And Mid$(Parts(X), Z, 1) <> "0" Then
Letter = Left(Parts(X), Z + (Left(Parts(X), 1) Like "[A-Za-z" & Chr$(1) & "]"))
Exit For
End If
Next
Numbers = Split(Replace(Parts(X), Letter, ""), "-")
If Numbers(1) < Numbers(0) Then
MsgBox "Sıralamayı ters girdiniz"
End
End If
If Not Numbers(1) Like "*[!0-9" & Chr$(1) & "]*" Then Numbers(1) = Val(Replace(Numbers(1), Chr$(1), "0"))
On Error GoTo SomethingIsNotRight
For Z = Numbers(0) To Numbers(1) Step Sgn(-(CLng(Numbers(1)) > CLng(Numbers(0))) - 0.5)
ExpandedSeries = ExpandedSeries & Delimiter & Letter & Z
Next
Else
ExpandedSeries = ExpandedSeries & Delimiter & Parts(X)
End If
Next
ExpandedSeries = Replace(Mid(ExpandedSeries, Len(Delimiter) + 1), Chr$(1), "")
seri = ExpandedSeries
Exit Function
SomethingIsNotRight:
ExpandedSeries = CVErr(xlErrValue)
End Function
Özel Arama
sayfa yazdırma alanına önce 3. ve 4. sayfa alanı sonra da 1. ve 2. sayfa alanı girdim.
