Sub HideRowWhereSecondColumnBlank()
  Dim Pwd As String
  Dim oRow As Integer
  Dim oTable As Table
  Dim iTable As Table
  Dim pState As Boolean
  With ActiveDocument
    pState = False

    If .Tables.Count > 0 Then
      For Each iTable In .Tables
        If iTable.Tables.Count > 0 Then
          For Each oTable In iTable.Tables
            For oRow = oTable.Rows.Count To 1 Step -1
              If Len(Replace(oTable.Cell(oRow, 2).Range.Text, Chr(13) & Chr(7), vbNullString)) = 0 Then
                 On Error Resume Next 'skip vertically merged cells
                 oTable.Rows(oRow).Delete
              End If
            Next oRow
          Next oTable
        End If
      Next iTable
    End If
    If pState = True Then .Protect wdAllowOnlyFormFields, Noreset:=True, Password:=Pwd
      pState = False
    Pwd = ""
  End With
 
End Sub

Sub MailMergeToDoc()
Application.ScreenUpdating = False
Dim Tbl As Table, r As Long
ActiveDocument.MailMerge.Execute
With ActiveDocument
  For Each Tbl In .Tables
    With Tbl
      For r = .Rows.Count To 3 Step -1
        With .Rows(r)
          If Len(.Cells(2).Range.Text) = 2 Then .Delete
        End With
      Next
    End With
  Next
End With
Application.ScreenUpdating = False
End Sub