Skipping cells with zero in macro loop to create graduation certificates

[ahendri2]

I am trying to create a vba that skips cells with zero in it while creating certificates in word. The cells have zero because I have to create cells that feed on a student roster. I have a standard 133 cells on the roster because schools across the country have different sizes that don't exceed 133. As a result, the certificate roster feeds from the main roster, making some of the cells zero. How do I ckip the zero while leaving the range for the whole 133 slots.

Here is the code:

Sub WordMailMerge()


'Step 1:  Declare your variables
    Dim wd As Word.Application
    Dim wdDoc As Word.Document
    Dim MyRange As Excel.Range
    Dim MyCell As Excel.Range
    Dim txtRank As String
    Dim txtLastName As String
    Dim txtFirstName As String
  
'Step 2:  Start Word and add a new document
    Set wd = New Word.Application
    Set wdDoc = wd.Documents.Add
    wd.Visible = True
    
    wdDoc.PageSetup.Orientation = wdOrientLandscape
    
'Step 3:  Set the range of your contact list
    Set MyRange = Sheets("Certificates").Range("A2:A121")
    
'Step 4:  Start the loop through each cell
    For Each MyCell In MyRange.Cells
    
    
'Step 5:  Assign values to each component of the letter
    txtRank = MyCell.Value
    txtFirstName = MyCell.Offset(, 2).Value
    txtLastName = MyCell.Offset(, 1).Value
   
'Step 6:Insert the structure of template document
    wd.Selection.InsertFile _
    ThisWorkbook.Path & "" & "certificate of graduation JLS.docx"
    
'Step 7:  Fill each relevant bookmark with respective value
    wd.Selection.Goto What:=wdGoToBookmark, Name:="Rank"
    wd.Selection.TypeText Text:=txtRank
    
    wd.Selection.Goto What:=wdGoToBookmark, Name:="FirstName"
    wd.Selection.TypeText Text:=txtFirstName
    
    wd.Selection.Goto What:=wdGoToBookmark, Name:="LastName"
    wd.Selection.TypeText Text:=txtLastName
    
'Step 8:  Clear any remaining bookmarks
    On Error Resume Next
    wdDoc.Bookmarks("Rank").Delete
    wdDoc.Bookmarks("FirstName").Delete
    wdDoc.Bookmarks("LastName").Delete
   
'Step 9:  Go to the end, insert new page, and start with the next cell
    wd.Selection.EndKey Unit:=wdStory
    wd.Selection.InsertBreak Type:=wdPageBreak
    Next MyCell
    
'Step 10:  Set cursor to beginning and clean up memory
    wd.Selection.HomeKey Unit:=wdStory
    wd.Activate
    Set wd = Nothing
    Set wdDoc = Nothing
    
End Sub

 

[Macropod]

Is there a reason for not using mailmerge to do this?

 

[ahendri2]

I have multiple instructors using the document who are sometimes older. Mail merge is to many steps for them. The posted code works when assigned toa button, but it still merges the auto filter zero's.

 

[Macropod]

I have multiple instructors using the document who are sometimes older. Mail merge is to many steps for them.

What, opening a mailmerge main document, answering 'Yes' to the SQL prompt, then clicking on 'Finish & Merge' is too complicated???

 

[ahendri2]

It sounds bad, but yes, sometimes when you have older staff or staff is not technology sound, everything has to be simple. A macro linked button will make it easier for them. Can you help?

 

[Macropod]

You could even automate the mailmerge in Word by executing it from a Document_Open macro, so users need do no more than answer 'Yes' to the SQL prompt - and even the need for that can be eliminated. I doubt anything you can do in Excel can be made as simple as that!

That said, there is something fundamentally flawed in your coding assumption every sheet uses 121 rows instead of finding out what the actual last-used row is. That, too, is inconsistent with your reference to 133 'cells'. Consider:

With Sheets("Certificates")
  Set MyRange = .Range("A2:A" & .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row)
End With

Your method of working with Word bookmarks is also very inefficient. Consider:

With wdDoc
  With .Bookmarks("Rank")
    .Range.Text = txtRank
    .Delete
  End With
  With .Bookmarks("FirstName")
    .Range.Text = txtFirstName
    .Delete
  End With
  With .Bookmarks("LastName")
    .Range.Text = txtLastName
    .Delete
  End With
End With

Hint - Instead of:
Dim wd As Word.Application
...
Set wd = New Word.Application
use:
Dim wd As New Word.Application

 

[ahendri2]

Thank you,

I might not have the terminology right and this is the first VBA code I have ever done. I tried what you suggested to skip the rows with no record, but it continued to make certificates. However, your suggestion for the bookmarks does seem to be more efficient. Is there a way to tell it to skip rows with zero?

 

[Macropod]

I tried what you suggested to skip the rows with no record, but it continued to make certificates.

That suggests you have used and unused rows interspersed. One might ask: why?

Try:

Sub CreateCertificates()
'Step 1: Declare variables
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim MyRange As Excel.Range, xlRng As Excel.Range
'Step 2:  Set the range of the certificate list
With Sheets("Certificates")
  Set MyRange = .Range("A2:A" & .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row)
End With
  
'Step 2: Start Word and add a new document
Set wdDoc = wdApp.Documents.Add
With wdDoc
  .PageSetup.Orientation = wdOrientLandscape
  'Step 3: Start the loop through each used row, skipping empty rows
  For Each xlRng In MyRange.Cells
    If xlRng.Value <> "" Then
      'Step 4: Insert a certificate
      .InsertFile Filename:=ThisWorkbook.Path & "\certificate of graduation JLS.docx", Range:=.Characters.Last
      'Step 5: Update & delete certificate bookmarks
      With .Bookmarks("Rank")
        .Range.Text = xlRng.Value
        .Delete
      End With
      With .Bookmarks("FirstName")
        .Range.Text = xlRng.Offset(, 2).Value
        .Delete
      End With
      With .Bookmarks("LastName")
        .Range.Text = xlRng.Offset(, 1).Value
        .Delete
      End With
      'Step 6: Insert new page, and start with the next cell
      .Characters.Last.InsertBreak Type:=wdPageBreak
    End If
  Next xlRng
  'Step 7: Delete empty last page
  .Characters.Last.Previous.Delete
End With
'Step8: Display the document
wdApp.Visible = True: wdApp.Activate
'Step9: Cleanup
Set wdDoc = Nothing: Set wdApp = Nothing: Set MyRange = Nothing
End Sub