Çözüldü VBA | Word Mail Merge Hk.

[RBozkurt]

Merhaba
Excel'de makro ile listeyi hazırlayıp aşağıdaki kod ile aynı klasöre kaydediyorum.
2 problem var çözemediğim.
1. problem : Tüm verilere ait doldurma işlemini yapıyor. Son veriden sonra boş olarak sayfalar oluşturuyor.
2. problem : Çıktıyı PDF olarak kaydedemedim. Word çalışıyor. PDF Kodlarını denedim dosya bozuk hatası veriyor.

Yardımcı olabilirseniz sevinirim. İyi çalışmalar.

Sub VBAMailMerge()
  Dim wdDoc As Object
  Dim wdApp As Object
  Dim strExcelPath As String
  Dim strWordTemplate As String
  Dim strSavePath As String

  strExcelPath = ThisWorkbook.Path & "\etiketRA.xlsm"
  strWordTemplate = ThisWorkbook.Path & "\etiketRA.docx"
  strSavePath = ThisWorkbook.Path & "\Etiket "

  Set wdApp = CreateObject("Word.Application")
    If wdApp Is Nothing Then
    Set wdApp = CreateObject("Word.Application")
    End If

  For Each wdDoc In wdApp.Documents
    wdDoc.Close SaveChanges:=True
  Next

  wdApp.Visible = True
  Set wdDoc = wdApp.Documents.Open(strWordTemplate)
  wdDoc.Save
  wdDoc.MailMerge.MainDocumentType = wdFormLetters
  wdDoc.MailMerge.OpenDataSource _
    Name:=strExcelPath, _
    LinkToSource:=True, _
    ReadOnly:=False, _
    AddToRecentFiles:=False, _
    PasswordDocument:="", _
    PasswordTemplate:="", _
    Revert:=False, _
    WritePasswordDocument:="", _
    WritePasswordTemplate:="", _
    Connection:="", _
    SQLStatement:="SELECT * FROM `Etiket$`"
  wdDoc.MailMerge.Destination = wdSendToNewDocument
  wdDoc.MailMerge.SuppressBlankLines = True
  With wdDoc.MailMerge
    .Execute
    .Destination = wdSendToPrinter
    .SuppressBlankLines = True
  End With

  Dim newDoc As Object
  Set newDoc = wdApp.ActiveDocument

  newDoc.SaveAs2 Filename:=strSavePath & Date & ".docx" _
            , FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
            AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
            EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
            :=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
  newDoc.Close SaveChanges:=True

  For Each wdDoc In wdApp.Documents
    wdDoc.Close SaveChanges:=True
  Next
  wdApp.Quit
End Sub

 

[RBozkurt]

Günceldir.

 

[Mahmut Kök]

Kodlarınızda bir iki ufak değişiklik yaptım. VB ekranında Tools>References kısmından Microsoft Word kütüphanesinin (Microsoft Word xx Object Library) eklenmiş olduğuna dikkat edin.

Sadece işinizi görecek değişiklikleri yaptım ancak bence kodlarınızda iyileştirilebilecek birçok yer mevcut.

İyi çalışmalar...

 

[RBozkurt]

Kodlarınızda bir iki ufak değişiklik yaptım. VB ekranında Tools>References kısmından Microsoft Word kütüphanesinin (Microsoft Word xx Object Library) eklenmiş olduğuna dikkat edin.

Sadece işinizi görecek değişiklikleri yaptım ancak bence kodlarınızda iyileştirilebilecek birçok yer mevcut.

İyi çalışmalar...

Merhaba sayın @Mahmut Kök
PDF kaydetme işlemi düzelmiş,
1. bahsettiğim işlem hakkında çözüm varmıdır?
5 sayfa veri 15 sayfada ek olarak hazırlıyor.

 

[Mahmut Kök]

Bahsettiğiniz 1. işlem için de düzeltme yapmıştım. Sadece ilgili kodları alarak deneme yaptıysanız bir de gönderdiğim Excel ile deneme yapınız. Ben yeniden denediğimde sadece verilerin olduğu kadar sayfa basıyor.

Belirttiğiniz sorunun sebebi; verileri aralarda boşluklar olacak şekilde ekliyor ve sonrasında boşlukları siliyorsunuz. Boşlukları silseniz bile boş olan yerler bellekte kalmaya devam ediyor ve o yüzden o boş satırlar kadar yine etiket oluşturuyor. O kısımlarda iyileştirme yapmanızı öneririm. Satır sildiğiniz kodlarda, silme işleminden sonra Excel'i kaydederek (.Save) değişiklikleri uygulamıştım. O kısımda ekran güncelleme (screen uptade) özelliğini etkin kılmanız da faydalı olabilir. Sorunu çözemezseniz yine mesaj gönderebilirsiniz.

 

[RBozkurt]

İlginize teşekkürler sayın @Mahmut Kök. Problemler çözülmüş durumdadır. Sağolun.