Tablodaki belirtilen sütundaki değerlere göre Toplu olarak tabloyu pdf lere ayırmak

[yenilik025]

Merhabalar,
Ekli tablodaki verileri G sütunu dikkate alınarak Önce Başlık sonra Tablo başlıkları eklenerek g sütunundaki farklı değerlere göre bilgisayarımda pdf oalrak nasıl kaydedebilirim ? Örnek sayfayı da belirttim.

 

[RBozkurt]

Merhaba, modüle ekleyerek deneyiniz.

Sub PdfKaydet_Filtre()
  Dim ws As Worksheet
  Set ws = ThisWorkbook.Sheets("Sayfa1")
  Dim LastRow As Long
  LastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
  Dim FilterRange As Range
  Set FilterRange = ws.Range("G2:G" & LastRow)
  Dim FilterValues() As Variant
  FilterValues = GetFilterValues(FilterRange)
  Dim i As Long
  For i = LBound(FilterValues) To UBound(FilterValues)
    ws.Range("G2:G" & LastRow).AutoFilter Field:=1, Criteria1:=FilterValues(i)
    ws.Range("A1", ws.Cells(ws.Rows.Count, "G").End(xlUp)).Select
    ActiveSheet.PageSetup.PrintArea = Selection.Address
    ActiveSheet.PageSetup.FitToPagesWide = 1
    ActiveSheet.PageSetup.FitToPagesTall = 1
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
      ThisWorkbook.Path & "\" & FilterValues(i) & "_Grup.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  Next i
  ws.AutoFilterMode = False
End Sub

Function GetFilterValues(FilterRange As Range) As Variant
  Dim FilterValues() As Variant
  Dim FilterCell As Range
  Dim i As Long
  i = 0
  For Each FilterCell In FilterRange
    If FilterCell.Value <> "" Then
      i = i + 1
      ReDim Preserve FilterValues(1 To i)
      FilterValues(i) = FilterCell.Value
    End If
  Next FilterCell
  GetFilterValues = FilterValues
End Function

 

[yenilik025]

Hocam denedim ancak hata alıyorum kodu ekleyeip dosya payalaşabilir misiniz ? hatamı bulamadım 1004 ve 1005 hatası alıyorum bir de pdf leri nereye oluşturuyor ?

 

[RBozkurt]

2. numaralı makroyu güncelledim.

 

[yenilik025]

2. numaralı makroyu güncelledim.

Hocam çok teşekkür ederim sanırım küçük bir durum daha kaldı ama çözemedim yolu mu üretemiyor ?

 

[RBozkurt]

Yukarıdaki dosya çalışıyor kendim denedim 2-3 defa.
Sürüm farkından kaynaklı muhtemelen, aşağıdakini deneyiniz, deneme imkanım yok.

Sub PdfKaydet_Filtre2007 ()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sayfa1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
Dim FilterRange As Range
Set FilterRange = ws.Range("G2:G" & LastRow)
Dim FilterValues() As Variant
FilterValues = GetFilterValues(FilterRange)
Dim i As Long
For i = LBound(FilterValues) To UBound(FilterValues)
ws.Range("G2:G" & LastRow).AutoFilter Field:=1, Criteria1:=FilterValues(i)
ws.Range("A1", ws.Cells(ws.Rows.Count, "G").End(xlUp)).ExportAsFixedFormat _
Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "" & FilterValues(i) & "_Grup.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
Next i
ws.AutoFilterMode = False
End Sub

Function GetFilterValues(FilterRange As Range) As Variant
Dim FilterValues() As Variant
Dim FilterCell As Range
Dim i As Long
i = 0
For Each FilterCell In FilterRange
If FilterCell.Value <> "" Then
i = i + 1
ReDim Preserve FilterValues(1 To i)
FilterValues(i) = FilterCell.Value
End If
Next FilterCell
GetFilterValues = FilterValues
End Function

 

[veyselemre]

Sub pdflereBol()

    Dim lr&, rng As Range, lst, grp

    With ActiveSheet
        
        lr = .Cells(Rows.Count, "G").End(3).Row
        If lr > 2 Then
            Set rng = .Range("A2:G" & lr)

            .PageSetup.PrintArea = "A1:G" & lr
            .PageSetup.Orientation = xlPortrait

            .Range("M:M").Clear
            rng.Columns(7).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("M1"), Unique:=True

            lr = .Cells(Rows.Count, "M").End(3).Row

            For Each grp In .Range("M2:M" & lr).Value
                rng.AutoFilter Field:=7, Criteria1:=grp
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                                     ThisWorkbook.Path & "\" & grp & "_Grup.pdf", Quality:=xlQualityStandard
            Next
            .AutoFilterMode = False
            .Range("M:M").Clear
        End If
        
    End With

End Sub

 

[yenilik025]

Hocam çok Teşekkür ederim evet böldü işlem tamamlandı .