Koşullu ve Birleştirerek Pdf Kaydetme

[ofd2008]

Hocam, yeni kodlamada sistemin çalışmasında bir sıkıntı söz konusu. Çıktı sayfasını en sola kaydırdım ve sayfa sıralaması Çıktı-1-2-3-4 oldu.
Ancak örnekteki dosyada sadece tablo 3 için çıktı alıyorum, sayfadaki tüm tabloların çıktısını veriyor ve tablo için belirtilen hücre aralığını almıyor. Sayfa ön izlemedeki sayfa ölçeği nereye denk geliyorsa içi dolu olan sayfalarını çıktısını veriyor. Eskisi gibi sıralamayı 1-2-3-4-Çıktı yapınca sorun yok ilgili hücre aralıklarını alıyor.
Hayırlı Günler.

 

[halit3]

Kod:

Sub pdfaktar3()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
yer = ActiveSheet.Name
sut = "g"

Set s1 = Sheets(yer)
For t = 2 To s1.Cells(Rows.Count, sut).End(3).Row
s1.Cells(t, "f") = ""
Next t


Dim Picture As Object

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn Then
Say1 = Picture.BottomRightCell.Row
s1.Cells(Say1, "f") = "Evet"
End If
End If
Next Picture



say3 = ActiveWorkbook.Sheets.Count
ReDim deg1(say3)
ReDim sayfa(50)

For j = 1 To say3
deg1(j) = Sheets(j).Name
Sheets(Sheets(j).Name).ResetAllPageBreaks
Sheets(Sheets(j).Name).PageSetup.PrintArea = ""
Next



say2 = 0

    For r = 2 To s1.Cells(Rows.Count, sut).End(3).Row
    aranan3 = s1.Cells(r, sut)
    Say4 = 0
    deg2 = ""
    
    If WorksheetFunction.CountIf(s1.Range("g2:g" & r), aranan3) = 1 Then
    
              For i = r To s1.Cells(Rows.Count, sut).End(3).Row
              If s1.Cells(i, "f") = "Evet" And aranan3 = s1.Cells(i, sut) Then
              Say4 = Say4 + 1
              
              If Say4 = 1 Then
              deg2 = s1.Cells(i, "h")
              Else
              deg2 = deg2 & "," & s1.Cells(i, "h")
              End If
            
              End If
              Next i
        
        If deg2 <> "" Then
            If IsNumeric(aranan3) = True Then aranan3 = "" & aranan3 & ""
            Sheets(aranan3).View = xlPageBreakPreview ' sayfa sonu ön izleme
            Sheets(aranan3).PageSetup.PrintArea = deg2
            say2 = say2 + 1
            sayfa(say2) = aranan3
            
            If UBound(Split(deg2, ",")) <= 0 Then
            Sheets(aranan3).VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
            Sheets(aranan3).HPageBreaks(1).DragOff Direction:=xlDown, RegionIndex:=1

            End If
            Sheets(aranan3).View = xlNormalView 'sayfa normal
        
        End If
    
    
    End If
    Next r



If say2 = 0 Then Exit Sub

Dim myArray() As Variant
m = 0
For i = 1 To say2
ReDim Preserve myArray(m)
myArray(m) = sayfa(i)
m = m + 1
Sheets(sayfa(i)).Move Before:=Sheets(m)
Next i

Sheets(myArray).Select

Dim Yol As String

Yol = ThisWorkbook.Path
Say5 = CreateObject("Scripting.FileSystemObject").getfolder(Yol).Files.Count + 1

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & Say5 & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True


For j = 1 To say3
Sheets(deg1(j)).Move Before:=Sheets(j)
Next

Sheets(yer).Select

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

End Sub

 

[ofd2008]

Teşekkür ederim Halit Bey, kod tam istediğimiz gibi çalışıyor.
Hayırlı günler dilerim.

 

[ofd2008]

Hocam, kodlara üst ve alt bilgi eklemeye çalıştım çıktı alırken üst ve alt bilgi pdfye eklenmiş olarak geliyor. Ancak bu üst ve alt bilgiyi hem excele hemde pdf ye ekliyor. Excel içerisinde bir değişiklik olmamasını sadece pdf de eklenmesini nasıl sağlayabilirim. Aşağıdaki kodu Dim Yol As String kodundan önce ekledim.

Dim WS As Worksheet
For Each WS In Worksheets
    WS.PageSetup.LeftHeader = "Firma Adı" & Chr(10) & "&D  &B&ITime:&I&B&T"
    WS.PageSetup.RightFooter = "Sayfa &P / &N"
Next WS