Macro'da Kişiler İle İlgili Topluca PDF Çıktıları Oluşturulması

Aşağıdaki prosedür, Excel'de her bir satırda ve bu satıların kolonlarındaki bilgileri istenilen formatta düzenleyip birer PDF dosyası oluşturmaktadır. 
Dosya Yolu klasöründeki fotoğrafları, Excel dosyasındaki ilgili kolonlara ve PDF dosyasına kopyalamaktadır. 

------------------------------------------------------------------------------------------------------------------------
Sub CreateOutputsInPDF()

 Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet

 DosyaYolu = Sheets("Parametreler").Range("B1")
 DosyaUzantisi = "jpg"
 Application.ScreenUpdating = True

 For Each Shape In ActiveSheet.Shapes
  If Shape.Name <> "Rectangle 1" Then
   Shape.Delete
  End If
 Next
 
 Columns(4).ColumnWidth = Sheets("Parametreler").Range("B2")    'Fotoğraf kolonu genişliği
 
 SonSatirNo = Cells(Rows.Count, "A").End(xlUp).Row
 
 For r = 2 To SonSatirNo
    Rows(r).RowHeight = Sheets("Parametreler").Range("B3")

    DosyaAdi = Range("A" & r)
    DosyaTumBilgileri = DosyaYolu & DosyaAdi & "." & DosyaUzantisi
 
    If File_Exists(DosyaTumBilgileri) Then
     ActiveSheet.Pictures.Insert(DosyaTumBilgileri).Select
     With Selection
        .Left = Range("D" & r).Left
        .Top = Range("D" & r).Top
        .ShapeRange.Height = 250#
        .ShapeRange.Width = 120#
     End With
    End If
    Set wdApp = New Word.Application
    Set wdDoc = wdApp.Documents.Add
    wdApp.Selection.TypeParagraph
    wdApp.Selection.Font.Bold = False
    wdApp.Selection.Font.Size = 12
 
    DosyaAdi = Range("A" & r)
    DosyaTumBilgileri = DosyaYolu & DosyaAdi & "." & DosyaUzantisi

    If File_Exists(DosyaTumBilgileri) Then
     wdDoc.Content.InlineShapes.AddPicture (DosyaTumBilgileri)
    End If

    wdApp.Selection.TypeText Text:="Adı Soyadı: "
    wdApp.Selection.TypeText Text:=Range("A" & r) & vbCrLf
    wdApp.Selection.TypeText Text:="Doğum Yeri: " & Range("B" & r) & vbCrLf
    wdApp.Selection.TypeText Text:="Doğum Tarihi: " & Range("C" & r) & vbCrLf
    wdApp.Selection.TypeText Text:=Sheets("Parametreler").Range("B4") & vbCrLf
    wdApp.Selection.TypeText Text:=Range("E1") & ": " & Range("E" & r) & vbCrLf
    wdApp.Selection.TypeText Text:=Range("F1") & ": " & Range("F" & r) & vbCrLf
    wdApp.Selection.TypeText Text:=Range("G1") & ": " & Range("G" & r) & vbCrLf
    wdApp.Selection.TypeText Text:=Range("H1") & ": " & Range("H" & r) & vbCrLf
    wdApp.Selection.TypeText Text:=Sheets("Parametreler").Range("D5")
    
    wdDoc.PageSetup.PaperSize = wdPaperA3
    wdDoc.PageSetup.Orientation = wdOrientLandscape

    wdDoc.ExportAsFixedFormat OutputFileName:=Range("A" & r) & ".pdf", ExportFormat:=wdExportFormatPDF, openafterexport:=False
    wdDoc.Close wdDoNotSaveChanges

    wdApp.Visible = False
    wdApp.Quit
    
    Set wdDoc = Nothing
    Set wdApp = Nothing
 
 Next r
 Range("A1").Select
End Sub

------------------------------------------------------------------------------------------------------------------------
Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean
 On Error Resume Next
 If sPathName <> "" Then
   If IsMissing(Directory) Or Directory = False Then
    File_Exists = (Dir$(sPathName) <> "")
   Else
    File_Exists = (Dir$(sPathName, vbDirectory) <> "")
   End If
 End If
End Function
------------------------------------------------------------------------------------------------------------------------













































Yukarıdaki Veriler sayfasında kişilerin bilgileri yazılmaktadır. Çıktı oluşturan prosedür bu kolonlara göre ayarlanmıştır. Soru hücrelerine istenen başlıklar ve altındaki cevap hücrelerine ilgili karşılıklar girilmelidir. 

Aşağıdaki Parametreler sayfasındaki D5 hücresinde istenilen metin yazılmalıdır. B4 hücresine ilgili form başlığı girilmelidir. B1 hücresine fotoğrafların bulunduğu klasörün yolu yazılır. 






















Otomatik Oluşturulan PDF Dosyaları






















Oluşturulan PDF Dosyalardan Birinin İçeriği






















Bu blogdaki popüler yayınlar

Power BI'da Yeni Sütun Eklemek

Power BI Kullanımına Giriş

Power BI Üzerinde Fonksiyon Oluşturma ve Kullanma

Kümülatif Toplam

Ağırlıklı Ortalama Hesabı

SQL'de Group By Yaparak Rapor Oluşturmak

SQL'de Birden Fazla Tablodan Listeleme Yapmak

ETarihli Fonksiyonu

Bir Ürünün En Son Tarihli Fiyatının Bulunması