Filling in Word Table - text disapearing (1 Viewer)

mdnuts

Registered User.
Local time
Today, 02:19
Joined
May 28, 2014
Messages
128
Kind of odd. I have the following code creating a table inside of another table's cell. What is intended to happen is the first table writes a few rows out, then when it gets to a particular cell, it then creates the nested table and starts to populate it. When that's complete, the first table resumes populating and inserting, and so on.

First table works fine, but with the nested table - the table itself is created fine. If I watch the document being populated, I see each row being populated correctly. When it advances a row, the previous rows' text disappears. the only text that remains is the last set of text for that table. The main table resumes doing it's own thing just fine.

When I debug.print the values are correct and match what I initially see on the word table being printed.

I can understand this happening if I was inserting and removing rows but that's not the case here. Can anyone see something i'm missing?

Code:
      'here we are checking and inserting any applicable inheritances - or a second related table.
      r2 = 0 'start off at first table row
      sSQL2 = "Select qryInheritance.Control, qryInheritance.AP_Acronym, qryInheritance.CCI_Number, qryInheritance.Inheritable_Status, qryInheritance.Via from qryInheritance where qryInheritance.Control='" & fldControlMain & "' and Inheritable_Status='Inheritable' order by ID asc;"
      Set rs2 = db.OpenRecordset(sSQL2)
      If rs2.EOF Then
       'well shucks
      Else
        rs2.MoveLast
        rs2.MoveFirst
        strRowCount2 = rs2.RecordCount + 1
        Do Until rs2.EOF
          'set the variables from the table fields
          Set fldAP = rs2.Fields("AP_Acronym")
          Set fldCCI = rs2.Fields("CCI_Number")
          Set fldVia = rs2.Fields("Via")
          
          r2 = r2 + 1 'advance a row
          'here we are inserting a table 3 columns wide into this particular cell.
          'first we set a bookmark to indicate where we want the table to be
          ActiveDocument.Bookmarks.Add Name:="Inherit_" & r, Range:=oDoc.Tables(1).Cell(r, 2)
          Set oTable2 = oDoc.Tables.Add(oDoc.Bookmarks("Inherit_" & r).Range, strRowCount2, 3)
          ActiveDocument.Bookmarks(Index:="Inherit_" & r).Delete
          
          'start to populate the table
          If r2 = 1 Then 'header row
            Debug.Print fldControlMain & " - " & r2 & " - Yes"
            oTable2.Cell(r2, 1).Range.Text = "AP"
            oTable2.Cell(r2, 2).Range.Text = "CCI"
            oTable2.Cell(r2, 3).Range.Text = "Inherited By"
          End If
          
          Debug.Print fldControlMain & " - " & fldAP & " - " & fldCCI & " - " & fldVia
          oTable2.Cell(r2, 1).Range.Text = fldAP
          oTable2.Cell(r2, 2).Range.Text = fldCCI
          oTable2.Cell(r2, 3).Range.Text = fldVia
          
        rs2.MoveNext
        Loop
      End If
      'here is where we would be checking and inserting enhancements.
      r2 = 0
 

Minty

AWF VIP
Local time
Today, 07:19
Joined
Jul 26, 2013
Messages
10,368
The only thing I can see is that you would overwrite your header row as you are checking for r2 = 1 but then overwriting it?
 

Cronk

Registered User.
Local time
Today, 16:19
Joined
Jul 4, 2013
Messages
2,771
I suggest you put one or more break points in your loop and watch the document being filled with data. This should enable you to drill into where your code is not doing what you want.

You could make your code more efficient. When I'm exporting data to a Word document, I create a template and then open a new instance of the template. The document has the table created but only one row with the first cell containing a bookmark. I use the bookmark to position the word cursor there and then move through the fields, moving the cursor one cell right each time. If there is multiple records, the next row is added by moving to the next cell. If you want to insert a new table at the current cursor position, something like

Code:
   objWordApp.activeDocument.Tables.Add Range:=selection.Range, numRows:=1, numColumns:=3
   objWordApp.Selection.Tables(1).style = "Table Grid"

  rs2.MoveFirst
  '--Insert your header row
  with objWordApp.Selection
      .InsertAfter "AP"
     .MoveRight Unit:=wdCell
     .InsertAfter "CCI"
     .MoveRight Unit:=wdCell
     .InsertAfter "Inherited By"
     .MoveRight Unit:=wdCell
  rs2.movenext

   Do Until rs2.EOF
      .MoveRight Unit:=wdCell
      .InsertAfter rs2!AP_Acronym
      .MoveRight Unit:=wdCell
      .InsertAfter rs2!CCI_Number
      .MoveRight Unit:=wdCell
      .InsertAfter rs2!Via
      .MoveRight Unit:=wdCell

      rs2.movenext
   Loop
   end with
 

mdnuts

Registered User.
Local time
Today, 02:19
Joined
May 28, 2014
Messages
128
I suggest you put one or more break points in your loop and watch the document being filled with data. This should enable you to drill into where your code is not doing what you want.

You could make your code more efficient. When I'm exporting data to a Word document, I create a template and then open a new instance of the template. The document has the table created but only one row with the first cell containing a bookmark. I use the bookmark to position the word cursor there and then move through the fields, moving the cursor one cell right each time. If there is multiple records, the next row is added by moving to the next cell. If you want to insert a new table at the current cursor position, something like

Code:
   objWordApp.activeDocument.Tables.Add Range:=selection.Range, numRows:=1, numColumns:=3
   objWordApp.Selection.Tables(1).style = "Table Grid"

  rs2.MoveFirst
  '--Insert your header row
  with objWordApp.Selection
      .InsertAfter "AP"
     .MoveRight Unit:=wdCell
     .InsertAfter "CCI"
     .MoveRight Unit:=wdCell
     .InsertAfter "Inherited By"
     .MoveRight Unit:=wdCell
  rs2.movenext

   Do Until rs2.EOF
      .MoveRight Unit:=wdCell
      .InsertAfter rs2!AP_Acronym
      .MoveRight Unit:=wdCell
      .InsertAfter rs2!CCI_Number
      .MoveRight Unit:=wdCell
      .InsertAfter rs2!Via
      .MoveRight Unit:=wdCell

      rs2.movenext
   Loop
   end with
..not even worrying about how long or wide the table is..

i like it.
 

mdnuts

Registered User.
Local time
Today, 02:19
Joined
May 28, 2014
Messages
128
The only thing I can see is that you would overwrite your header row as you are checking for r2 = 1 but then overwriting it?

yeah I did see that and had moved it into a if/else - same thing though.
 

Cronk

Registered User.
Local time
Today, 16:19
Joined
Jul 4, 2013
Messages
2,771
Yes, the header bit as well as the add table were both in your loop, the latter probably explaining the table being generated in side the first cell. I had the table creation and header before the loop. Yes you can do this using a test for the first record in the loop, but it's not as elegant.
 

mdnuts

Registered User.
Local time
Today, 02:19
Joined
May 28, 2014
Messages
128
Currently I've got this.

What happens with it is it creates the nested table, then starts iterating on the parent table and also iterates on the nested table, and doesn't exit out. I'm guessing it is because Table(1) keeps getting called instead of some other reference, but if I try to debug how many tables are on the document - only one is shown.

Code:
   '/////////////////////////////

    r2 = 0 'start off at first table row
    sSQL2 = "Select qryInheritance.Control, qryInheritance.AP_Acronym, qryInheritance.CCI_Number, qryInheritance.Inheritable_Status, qryInheritance.Via from qryInheritance where qryInheritance.Control='" & fldControlMain & "' and Inheritable_Status='Inheritable' order by ID asc;"
    Set rs2 = db.OpenRecordset(sSQL2)
    If rs2.EOF Then
     'well shucks
    Else
      Set myRange = oDoc.Range(Start:=oDoc.Tables(1).Cell(r, 2).Range.Start, End:=oDoc.Tables(1).Cell(r, 2).Range.End)
      oWord.ActiveDocument.Tables.Add Range:=myRange, numRows:=1, numColumns:=3
      oWord.Selection.Tables(1).Style = "Table Grid"
        
      rs2.MoveFirst
      '--Insert your header row
      With oWord.Selection
        .InsertAfter "AP"
        .MoveRight Unit:=wdCell
        .InsertAfter "CCI"
        .MoveRight Unit:=wdCell
        .InsertAfter "Inherited By"
        .MoveRight Unit:=wdCell
      rs2.MoveNext
        
      Do Until rs2.EOF
        .MoveRight Unit:=wdCell
        .InsertAfter rs2!AP_Acronym
        .MoveRight Unit:=wdCell
        .InsertAfter rs2!CCI_Number
        .MoveRight Unit:=wdCell
        .InsertAfter rs2!Via
        .MoveRight Unit:=wdCell
      rs2.MoveNext
      Loop
      End With
    End If
    '/////////////////////////////

It should be something like this.

main table rowmain table text
main table stuff
APCCIInherited From
AC-1.2000001There
AC-1.3000020Here
main table Row 2main table text2
main table stuff 2
APCCIInherited From
AC-2.10002010Where
AC-2.20002110Near
 

Minty

AWF VIP
Local time
Today, 07:19
Joined
Jul 26, 2013
Messages
10,368
I think you have nailed up your problem - referring to a table in a table. Two possible suggestions
  • Create it separately then cut and paste it in code where you want it?
  • Make the output mimic the two tables and adjust the row height to hide the blank stuff?
 

mdnuts

Registered User.
Local time
Today, 02:19
Joined
May 28, 2014
Messages
128
Doing some research on it i discovered the index number is - well not meaningless, but relational so if you're in table 1 when you create it, the new one is table 2, but as soon as you select the newly created one - it is then known as Table 1. Makes it a bit meaningless for me. A lot of discussion that switching tables by bookmark is ideal - just trying to figure that whole part out now.
 

Cronk

Registered User.
Local time
Today, 16:19
Joined
Jul 4, 2013
Messages
2,771
If you are saying that you want to start a new table immediately after a previous table because the AP data has changed from AP-1.x to AP_2.1, or AP_43.x to AP_57.x then you test for that change in the record set loop and create a new table. If you want the AP values to be in ascending order, that would imply qryInheritance is ordered on qryInheritance.AP_Acronym



If so, then the table creation is now put back into the loop, but only exercised after testing if there is a change in the AP_n value each pass.

Code:
    dim strAP as string
    strAP=""

    r2 = 0 'start off at first table row
    sSQL2 = "Select qryInheritance.Control, qryInheritance.AP_Acronym, qryInheritance.CCI_Number, qryInheritance.Inheritable_Status, qryInheritance.Via from qryInheritance where qryInheritance.Control='" & fldControlMain & "' and Inheritable_Status='Inheritable' order by ID asc;"
    Set rs2 = db.OpenRecordset(sSQL2)
    If rs2.EOF Then
     'well shucks
    Else
        
      rs2.MoveFirst
      '--Insert your header row
      With oWord.Selection
        if strAP <> left(rs2!AP_Acronym,4) then  '--test if we are still in the same AP sequence
            '---  start new table
            Set myRange = oDoc.Range(Start:=oDoc.Tables(1).Cell(r, 2).Range.Start, End:=oDoc.Tables(1).Cell(r, 2).Range.End)
            oWord.ActiveDocument.Tables.Add Range:=myRange, numRows:=1, numColumns:=3
            oWord.Selection.Tables(1).Style = "Table Grid"
        endif       

        .InsertAfter "AP"
        .MoveRight Unit:=wdCell
        .InsertAfter "CCI"
        .MoveRight Unit:=wdCell
        .InsertAfter "Inherited By"
        .MoveRight Unit:=wdCell
      rs2.MoveNext
        
      Do Until rs2.EOF
         '--start a new table at the current cursor position
          
        .MoveRight Unit:=wdCell
        .InsertAfter rs2!AP_Acronym
        .MoveRight Unit:=wdCell
        .InsertAfter rs2!CCI_Number
        .MoveRight Unit:=wdCell
        .InsertAfter rs2!Via

        rs2.MoveNext

        if strAP <> left(rs2!AP_Acronym,4) then  '--test if we are still in the same AP sequence
         if strAP<> "" then   
             '--finish the previous table
             .MoveDown Unit:=wdLine, Count:=1
             .TypeParagraph
         else
             '--start a new row in the current table
             .MoveRight Unit:=wdCell
         end if

         Loop
         End With
    End If

Note this is air code ie not tested.

And if you're wondering, I am not particularly proficient with Word VBA. I record the macro steps in Word and copy the generated vba into Access, modifying it as necessary.
 

mdnuts

Registered User.
Local time
Today, 02:19
Joined
May 28, 2014
Messages
128
Thanks,
not create one immediately after a table is created, but while creating a table, when a particular cell is being made, insert a new table inside that cell. I've done the create macro and attempt to copy it, it just really doesn't like using selection. or anything with select while inside a table - for some reason.

@Minty last comment made me think why mess with nested tables. I'm currently trying to write out one table, inserting rows and such where needed and then later iterate through the entire table merging unneeded cells, cleaning it up.

Who knows, i'll see how this idea fleshes out.
 

Cronk

Registered User.
Local time
Today, 16:19
Joined
Jul 4, 2013
Messages
2,771
There is a lot of work going back and inserting new rows into a table (and I'd expect even more time debugging the process). It is normally easier to use nested loops and second recordsets to insert rows sequentially.
 

mdnuts

Registered User.
Local time
Today, 02:19
Joined
May 28, 2014
Messages
128
Thanks @Cronk & @Minty . Here's what I ended up with. I'm sure it could be cleaned up a little - if someone had the desire (I don't).

Code:
  Dim rs As DAO.Recordset, rs2 As DAO.Recordset, rs3 As DAO.Recordset
  Dim db As Database
  Dim sSQL As String, sSQL2 As String
  'prepare the word doc
  Dim oWord As Word.Application
  Dim oDoc As Word.Document
  Dim oTable As Table
  Dim oRow As Row
  Dim oRange As Range
  Dim oCell As Cell
  Dim fEmpty As Boolean
  Dim r As Integer, r2 As Integer 'row count
  Dim i As Integer
  Dim CellCount As Integer
 
  i = 0
  Set db = CurrentDb
 
  Set oWord = CreateObject("Word.Application")
  oWord.Visible = True
  Set oDoc = oWord.Documents.Add
 
  'pull from the above inserted table
  sSQL = "SELECT qryFamiliesWEnhancements.[ID],qryFamiliesWEnhancements.[Title],qryFamiliesWEnhancements.[Impact],qryFamiliesWEnhancements.[Control_main],qryFamiliesWEnhancements.[Enhancement],qryFamiliesWEnhancements.[Control_ID] FROM qryFamiliesWEnhancements WHERE Impact Like ""*" & [Forms]![frmSelect]![cboSelect] & "*"" Order by ID asc;"
  Set rs = db.OpenRecordset(sSQL)
  rs.MoveFirst
  rs.MoveLast
 
  oWord.ActiveDocument.Tables.Add Range:=oDoc.Bookmarks("\endofdoc").Range, numRows:=1, numColumns:=5
  'oWord.Selection.Tables(1).Style = "Table Grid"
  rs.MoveFirst
  r = 0 'current row counter
  'insert word table however many records long plus two and 2 wide.
  'Set oTable = oDoc.Tables.Add(oDoc.Bookmarks("\endofdoc").Range, strRowCount, 3)
  'this creates a table that is three columns wide.  for the main part this will always merge columns 2 and 3.  those two columns are reserved for related text.
 
  'start the recordset loop reserving the top two rows for header type stuff.
  With oWord.Selection
    .TypeText "Control Identifier"
    .MoveRight Unit:=wdCell
    .TypeText "Control Name"
    .MoveRight Unit:=wdCell
    .MoveRight Unit:=wdCell
    .MoveRight Unit:=wdCell

    Do Until rs.EOF
      r = r + 1
      If r = 1 Then
        'blank row between controls
        .MoveRight Unit:=wdCell
        .MoveRight Unit:=wdCell
        .MoveRight Unit:=wdCell
        .MoveRight Unit:=wdCell
        .MoveRight Unit:=wdCell
      End If
      
      'first data row
      .MoveRight Unit:=wdCell
      .TypeText rs("Control_Main")
      .MoveRight Unit:=wdCell
      .TypeText rs("Title")
      .MoveRight Unit:=wdCell
      .MoveRight Unit:=wdCell
      .MoveRight Unit:=wdCell
      
      'second row
      .MoveRight Unit:=wdCell
      .MoveRight Unit:=wdCell
      .TypeText "Supplemental RSCD Guidance:"
      .MoveRight Unit:=wdCell
      .MoveRight Unit:=wdCell
      .MoveRight Unit:=wdCell
      
      'third row
      .MoveRight Unit:=wdCell
      .MoveRight Unit:=wdCell
      .TypeText "<<insert Supplemental Text Here>>"
      .MoveRight Unit:=wdCell
      .MoveRight Unit:=wdCell
      .MoveRight Unit:=wdCell
      
      'here is where we would enter in the cci table text if applicable
      sSQL2 = "Select qryInheritance.Control, qryInheritance.AP_Acronym, qryInheritance.CCI_Number, qryInheritance.Inheritable_Status, qryInheritance.Via from qryInheritance where qryInheritance.Control='" & rs("Control_main") & "' and Inheritable_Status='Inheritable' order by ID asc;"
      Set rs2 = db.OpenRecordset(sSQL2)
      If Not rs2.EOF Then
        'fourth row
        .MoveRight Unit:=wdCell
        .MoveRight Unit:=wdCell
        .MoveRight Unit:=wdCell
        .TypeText "Assessment Procedure Inheritance Status"
        .MoveRight Unit:=wdCell
        .MoveRight Unit:=wdCell

        .MoveRight Unit:=wdCell
        .MoveRight Unit:=wdCell
        .MoveRight Unit:=wdCell
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Font.Bold = True
        .TypeText "AP"
        .MoveRight Unit:=wdCell
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Font.Bold = True
        .TypeText "CCI"
        .MoveRight Unit:=wdCell
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Font.Bold = True
        .TypeText "Inherited By"
        
        rs2.MoveLast
        rs2.MoveFirst
        
        Do Until rs2.EOF
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .ParagraphFormat.Alignment = wdAlignParagraphCenter
          .Font.Bold = False
          .TypeText rs2("AP_Acronym")
          .MoveRight Unit:=wdCell
          .ParagraphFormat.Alignment = wdAlignParagraphCenter
          .Font.Bold = False
          .TypeText rs2("CCI_Number")
          .MoveRight Unit:=wdCell
          .ParagraphFormat.Alignment = wdAlignParagraphCenter
          .Font.Bold = False
          .TypeText rs2("Via")
        rs2.MoveNext
        Loop
      End If
      r = 0
      r2 = 0
      'now we need to check out enhancements
      sSQL2 = "SELECT qryFamiliesWEnhancementsSub.[ID],qryFamiliesWEnhancementsSub.[Title],qryFamiliesWEnhancementsSub.[Impact],qryFamiliesWEnhancementsSub.[Control_main],qryFamiliesWEnhancementsSub.[Enhancement],qryFamiliesWEnhancementsSub.[Control_ID] FROM qryFamiliesWEnhancementsSub WHERE Impact Like ""*" & [Forms]![frmSelect]![cboSelect] & "*"" and qryFamiliesWEnhancementsSub.[Control_main]='" & rs("Control_main") & "' Order by ID asc;"
      Set rs3 = db.OpenRecordset(sSQL2)
      If Not rs3.EOF Then
        rs3.MoveLast
        rs3.MoveFirst
        
        r2 = r2 + 1
        If r2 = 1 Then
          'blank row between controls
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
        End If
        Do While Not rs3.EOF
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .TypeText rs3("Enhancement")
          .MoveRight Unit:=wdCell
          .TypeText rs3("Title")
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
        
          'second row
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .TypeText "Supplemental RSCD Guidance:"
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
        
          'third row
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell
          .TypeText "<<insert Supplemental Text Here>>"
          .MoveRight Unit:=wdCell
          .MoveRight Unit:=wdCell

          'now Inheritance stuff
          'here is where we would enter in the cci table text if applicable
          sSQL2 = "Select qryInheritance.Control, qryInheritance.AP_Acronym, qryInheritance.CCI_Number, qryInheritance.Inheritable_Status, qryInheritance.Via from qryInheritance where qryInheritance.Control='" & rs3("Control_ID") & "' and Inheritable_Status='Inheritable' order by ID asc;"
          Set rs2 = db.OpenRecordset(sSQL2)
          If Not rs2.EOF Then
            'fourth row
            .MoveRight Unit:=wdCell
            .MoveRight Unit:=wdCell
            .MoveRight Unit:=wdCell
            .TypeText "Assessment Procedure Inheritance Status"
            .MoveRight Unit:=wdCell
            .MoveRight Unit:=wdCell
        
            .MoveRight Unit:=wdCell
            .MoveRight Unit:=wdCell
            .MoveRight Unit:=wdCell
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Font.Bold = True
            .TypeText "AP"
            .MoveRight Unit:=wdCell
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Font.Bold = True
            .TypeText "CCI"
            .MoveRight Unit:=wdCell
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Font.Bold = True
            .TypeText "Inherited By"
            rs2.MoveLast
            rs2.MoveFirst
            Do Until rs2.EOF
              .MoveRight Unit:=wdCell
              .MoveRight Unit:=wdCell
              .MoveRight Unit:=wdCell
              .ParagraphFormat.Alignment = wdAlignParagraphCenter
              .Font.Bold = False
              .TypeText rs2("AP_Acronym")
              .MoveRight Unit:=wdCell
              .ParagraphFormat.Alignment = wdAlignParagraphCenter
              .Font.Bold = False
              .TypeText rs2("CCI_Number")
              .MoveRight Unit:=wdCell
              .ParagraphFormat.Alignment = wdAlignParagraphCenter
              .Font.Bold = False
              .TypeText rs2("Via")
            rs2.MoveNext
            Loop
          End If 'end ap for enhancements
        r2 = 0
        rs3.MoveNext
        Loop
      End If 'end enhancement rs3
    rs.MoveNext
    Loop
  End With
 
  'start cleaning it up

 'end clean up section 
  'exit out of everything
  Set oDoc = Nothing
  oWord.Quit
  Set oWord = Nothing
  rs.Close
  Set rs = Nothing
  rs2.Close
  Set rs2 = Nothing
  rs3.Close
  Set rs3 = Nothing
  db.Close
  Set db = Nothing
End Sub
 

mdnuts

Registered User.
Local time
Today, 02:19
Joined
May 28, 2014
Messages
128
and the cleanup section - towards the bottom right before exiting out of everything.
Code:
  Dim n As Long, j As Long
  Set oTable = oDoc.Tables(1)

   With oTable
    n = oTable.Range.Rows.Count 'get a count of all the rows
    For i = 1 To n  'start looping through the rows
        If Len(oTable.Cell(i, 1).Range.Text) > 2 Then
        'start of a beautiful friendship, j/k - it is the start of a control row
          oTable.Cell(Row:=i, Column:=2).Merge MergeTo:=oTable.Cell(Row:=i, Column:=5)
          oTable.Cell(Row:=i, Column:=2).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
          oTable.Cell(Row:=i, Column:=1).Range.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
          oTable.Cell(Row:=i, Column:=2).Range.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
         'next is if only content in second column
        ElseIf Len(oTable.Cell(i, 1).Range.Text) = 2 And Len(oTable.Cell(i, 2).Range.Text) > 2 And Len(oTable.Cell(i, 3).Range.Text) = 2 And Len(oTable.Cell(i, 4).Range.Text) = 2 And Len(oTable.Cell(i, 5).Range.Text) = 2 Then 'total blank row
          oTable.Cell(Row:=i, Column:=2).Merge MergeTo:=oTable.Cell(Row:=i, Column:=5)
          oTable.Cell(Row:=i, Column:=2).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
      
          'next is if content in 2nd and third columns only (it is an enhancement)
        ElseIf Len(oTable.Cell(i, 1).Range.Text) = 2 And Len(oTable.Cell(i, 2).Range.Text) > 2 And Len(oTable.Cell(i, 3).Range.Text) > 2 And Len(oTable.Cell(i, 4).Range.Text) = 2 And Len(oTable.Cell(i, 5).Range.Text) = 2 Then 'total blank row
          oTable.Cell(Row:=i, Column:=3).Merge MergeTo:=oTable.Cell(Row:=i, Column:=5)
          oTable.Cell(Row:=i, Column:=3).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
          oTable.Cell(Row:=i, Column:=2).Range.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
          oTable.Cell(Row:=i, Column:=3).Range.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
          'next is if content in 3rd column only.
        ElseIf Len(oTable.Cell(i, 1).Range.Text) = 2 And Len(oTable.Cell(i, 2).Range.Text) = 2 And Len(oTable.Cell(i, 3).Range.Text) > 2 And Len(oTable.Cell(i, 4).Range.Text) = 2 And Len(oTable.Cell(i, 5).Range.Text) = 2 Then 'total blank row
          oTable.Cell(Row:=i, Column:=3).Merge MergeTo:=oTable.Cell(Row:=i, Column:=5)
                If InStr(1, oTable.Cell(Row:=i, Column:=3), "Supplemental") > 0 Then
            oTable.Cell(Row:=i, Column:=3).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
          Else
            oTable.Cell(Row:=i, Column:=3).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
          End If
          'last is if entire row is empty
        ElseIf Len(oTable.Cell(i, 1).Range.Text) = 2 And Len(oTable.Cell(i, 2).Range.Text) = 2 And Len(oTable.Cell(i, 3).Range.Text) = 2 And Len(oTable.Cell(i, 4).Range.Text) = 2 And Len(oTable.Cell(i, 5).Range.Text) = 2 Then 'total blank row
          oTable.Cell(Row:=i, Column:=1).Merge MergeTo:=oTable.Cell(Row:=i, Column:=5)
        End If
     Next i
  End With
 
Last edited:

mdnuts

Registered User.
Local time
Today, 02:19
Joined
May 28, 2014
Messages
128
I ended up redoing this somewhat when I attempted to insert a second table. freeflow over at StackOverflow offered a different way to create and then select the table and be able to still move through the table. You can notice you add a row, then move down to that row.

Code:
 oDoc.Tables.Add Range:=oDoc.Bookmarks("\endofdoc").Range, NumRows:=1, NumColumns:=5
  rs.MoveFirst
  r = 0 'current row counter
  'set myRow to the range of the first row in the last table in the document
  Set myRow = oDoc.Tables.Item(oDoc.Tables.Count).Range.Rows.First.Range
  myRow.Cells(1).Range.Text = "Control Identifier"
  myRow.Cells(2).Range.Text = "Control Name"
 
  oDoc.Tables(1).Rows.Add
  myRow.Move Unit:=wdRow, Count:=1
 
  Do Until rs.EOF
      r = r + 1
      If r = 1 Then
        oDoc.Tables(1).Rows.Add
        myRow.Move Unit:=wdRow, Count:=1
      End If
      
      'first data row
      'make a second bookmark to let it shoot back up.
      'bookmark the control name
      strBookMark = Replace(rs("Control_main"), "-", "") & "b"
      With oDoc.Bookmarks
        .Add Range:=myRow.Cells(1).Range, Name:=strBookMark
      End With
      myRow.Cells(1).Range.Font.Name = "Arial"
      myRow.Cells(1).Range.Font.Size = 12
      myRow.Cells(1).Range.Text = rs("Control_main")
      myRow.Move Unit:=wdCell, Count:=1
      myRow.Cells(1).Range.Text = rs("Title")
            
      'second row
      oDoc.Tables(1).Rows.Add
      myRow.Move Unit:=wdRow, Count:=1
      myRow.Move Unit:=wdCell, Count:=1
      myRow.Cells(1).Range.Font.Name = "Arial"
      myRow.Cells(1).Range.Font.Size = 12
      myRow.Cells(1).Range.Text = "Supplemental RSCD Guidance"
            
      'third row
      oDoc.Tables(1).Rows.Add
      myRow.Move Unit:=wdRow, Count:=1
      myRow.Move Unit:=wdCell, Count:=1
      myRow.Cells(1).Range.Font.Name = "Arial"
      myRow.Cells(1).Range.Font.Size = 12
      myRow.Cells(1).Range.Text = "<<Insert Supplemental Text Here>>"

then adding text after the first table and creating another table.

Code:
    '////////////// appendix b text
  Set myRange = oDoc.Tables(1).Range
  With myRange
    .Collapse wdCollapseEnd
    .InsertBreak Type:=wdPageBreak
  End With
 
  For i = 1 To 3
    Set oPara = oDoc.Paragraphs.Add()
    If i = 1 Then
      strText = "Appendix B"
      strSize = 24
      strBold = True
    End If
    If i = 2 Then
      strText = "NIST SP 800-53 RSCD-Relevant Controls"
      strSize = 12
      strBold = True
    End If
    If i = 3 Then
      strText = "This appendix provides a list of the information security controls from NIST Special Publication 800-53 Revision 4 that are directly relevant and apply to Research Scientific Computing Devices."
      strSize = 12
      strBold = False
    End If
    
    oPara.Range.Font.Name = "Arial"
    oPara.Range.Font.Size = strSize
    oPara.Range.Font.Bold = strBold
    oPara.Range.Text = strText & vbCr & vbCr
  Next i
  '/////////////// end appendix b text
 
  '/////////////// Start appendix b table
  strOld = ""
  oDoc.Tables.Add Range:=oDoc.Bookmarks("\endofdoc").Range, NumRows:=1, NumColumns:=3

  sSQL = "SELECT * from qryFullFamily WHERE Impact Like ""*" & [Forms]![frmSelect]![cboSelect] & "*"" order by [qryFullFamily].[ID] asc;"
  Set rs = db.OpenRecordset(sSQL)
  rs.MoveLast
  rs.MoveFirst

  Set myRow = oDoc.Tables.Item(oDoc.Tables.Count).Range.Rows.First.Range
 
  Do Until rs.EOF
    If Left(rs("Control_main"), 2) <> strOld Then 'it is a new control family and show the text as such.
      strOld = Left(rs("Control_main"), 2)
        myRow.Move Unit:=wdCell, Count:=1
        myRow.Cells(1).Range.Bold = True
        myRow.Cells(1).Range.Font.Italic = True
        myRow.Cells(1).Range.Font.Underline = wdUnderlineSingle
        myRow.Cells(1).Range.Font.Name = "Arial"
        myRow.Cells(1).Range.Font.Size = 12
        myRow.Cells(1).Range.Text = rs("Title")

and if you wanted to hyperlink - i've got bookmarks set in the code above it is like this.

Code:
            '/////////////
             With oDoc.Tables(r).Cell(i, 1)
               .Range.Hyperlinks.Add Anchor:=<<where link should appear>>, Address:="", SubAddress:=<<bookmark name>>, ScreenTip:="", TextToDisplay:=<<text to display such as bookmark name>>
             End With
 

Users who are viewing this thread

Top Bottom