Copying text from last row of multiple tables of different lengths

jrooney7 · #1 04-09-2019, 07:53 AM

Hello all,

I have a word document (*.dotm) that will have a random number of tables, some of which will have a first row containing the word "Worksheet" - e.g. "Firearm Worksheet", "Bullet Worksheet", etc. The code below is intended to loop through the tables in the document and if it finds one with the word "Worksheet" in the first row, it copies the text in the last row and pastes it to a destination cell in the last table of the document. However, the code as written copies based where the cursor is to begin with. If the cursor is in a table that is not the longest (there is some other table that contains more rows), the code is pulling text based on the length of that table, so it's not the last row. But if I put the cursor in the longest table in the document, it seems to be copying the last row correctly. I'm thinking it's a problem with my NumberOfRowsInCurrentTable setup. Ideally, the code should work regardless of which table the cursor is in, or even if the cursor is not in a table - I don't want the end-user having to figure out which is the longest table. Here is my code:

Code:

Sub Results()
'
' Results Macro
'
'
    Application.ScreenUpdating = False

    Dim LastTable As Integer
       LastTable = ActiveDocument.Range.Tables.Count
    Dim currentTableIndex As Integer
       currentTableIndex = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count
    Dim NumberOfRowsInCurrentTable As Integer
       NumberOfRowsInCurrentTable = ActiveDocument.Range.Tables(currentTableIndex).Rows.Count
    
    Dim t As Table
    
    For Each t In ActiveDocument.Tables
        t.Cell(1, 1).Range.Select
        Selection.Find.Execute FindText:="Worksheet"
        If Selection.Find.Found = True Then
            t.Cell(NumberOfRowsInCurrentTable, 1).Range.Select
            Selection.Range.Copy
            ' this section is for when the destination cell in the Results Table is empty
            If Len(ActiveDocument.Tables(LastTable).Tables(2).Cell(1, 2).Range.Text) = 3 Then
                ActiveDocument.Tables(LastTable).Tables(2).Cell(1, 2).Range.Select
                Selection.EndKey Unit:=wdLine
                Selection.PasteSpecial DataType:=wdPasteText
                ' this section is for when the destination cell in the Results Table already contains text
                ElseIf Len(ActiveDocument.Tables(LastTable).Tables(2).Cell(1, 2).Range.Text) > 3 Then
                ActiveDocument.Tables(LastTable).Tables(2).Cell(1, 2).Range.Select
                Selection.EndKey Unit:=wdLine
                Selection.TypeParagraph
                Selection.TypeParagraph
                Selection.PasteSpecial DataType:=wdPasteText
            End If
        End If
    Next
    
    Application.ScreenUpdating = True

End Sub

Any help is appreciated!

Guessed · #2 04-09-2019, 03:43 PM

Try this version

Code:

Sub Results2()
  Dim i As Integer, iTables As Integer
  Dim aTbl As Table, tblLast As Table
  Dim aRng As Range, aRngEnd As Range
  
  iTables = ActiveDocument.Tables.Count
  Set tblLast = ActiveDocument.Tables(iTables)
  
  For i = 1 To iTables - 1
    Set aTbl = ActiveDocument.Tables(i)
    Set aRng = aTbl.Range.Cells(1).Range
    If InStr(aRng.Text, "Worksheet") > 0 Then
      Set aRngEnd = tblLast.Range
      aRngEnd.Collapse Direction:=wdCollapseEnd
      aRngEnd.FormattedText = aTbl.Rows.Last.Range.FormattedText
    End If
  Next i
End Sub

Note that you will likely encounter problems if your tables have merged cells or the cell counts are not consistent in the last rows.

jrooney7 · #3 04-09-2019, 07:05 PM

So I ran this code with a variety of possible tables, one of which has vertically merged cells, and you were right, I got an error. So unfortunately, this code won't work for me, but I really appreciate the suggestion. Keep 'em coming!

Guessed · #4 04-09-2019, 08:15 PM

You haven't provided enough information. We don't know anything about your tables and the functionality is highly dependent on how those tables are formatted. Merged cells is one level of complexity, differences in column counts is another. The fact that the macro can only be run once (only after the content is completely ready) makes this one shot methodology kind of dodgy.

Why you need this functionality is yet the prime question? Wouldn't it be easier if you entered information in one location and it automatically appeared in a second specific location rather than having to run a macro to copy content. This could be done by cross-references or linked content controls for instance.

jrooney7 · #5 04-10-2019, 07:11 AM

Sorry if I've been too vague, I was trying to keep it simple. This word doc will allow forensic firearms examiners to document their examinations. The functionality has to be that the examiner can change the results section of any worksheets as needed and which frequently happens as a result of the review process of the case they're working on. Also by doing it this way, the compiler can be run again as many times as needed when changes are made.

That being said, each worksheet's last row is formatted identically - one column only that spans the width of the table. The destination cell is in a nested table that I have no control over. The code I posted originally pastes into the correct cell in that table (Cell 1, 2 of the nested table in the Results of Examination section). My problem is that the code isn't correctly identifying the last row in each worksheet unless the cursor is in the longest worksheet.

I've uploaded a worksheet (docm) that has been filled out. The code in question is in a macro called 'Results'.

I hope this clears things up. Thank you!

Guessed · #6 04-10-2019, 05:13 PM

Try this one

Code:

Sub Results2()
  Dim i As Integer, iTables As Integer
  Dim aTbl As Table, tblLast As Table, tblTgt As Table, aCellTgt As Cell
  Dim aRng As Range, aRngEnd As Range, aRngSource As Range
  
  iTables = ActiveDocument.Tables.Count
  Set tblLast = ActiveDocument.Tables(iTables)
  Set tblTgt = tblLast.Tables(2)
  Set aCellTgt = tblTgt.Cell(1, 2)
  aCellTgt.Range.Text = ""    'if you want to start with a blank cell
  
  For i = 1 To iTables - 1
    Set aTbl = ActiveDocument.Tables(i)
    Set aRng = aTbl.Range.Cells(1).Range
    If InStr(aRng.Text, "Worksheet") > 0 Then
      Set aRngSource = aTbl.Range.Cells(aTbl.Range.Cells.Count).Range
      aRngSource.MoveEnd Unit:=wdCharacter, Count:=-1
      Set aRngEnd = aCellTgt.Range
      aRngEnd.Collapse Direction:=wdCollapseEnd
      aRngEnd.MoveEnd Unit:=wdCharacter, Count:=-1
      aRngEnd.FormattedText = aRngSource.FormattedText
      aRngEnd.InsertAfter vbCr & vbCr
    End If
  Next i
End Sub

jrooney7 · #7 04-10-2019, 07:56 PM

That's fantastic! I tweaked just a little to change the formatting once the text is in there, but you just solved a problem that's been stumping me for months, literally! Thank you!!

Guessed · #8 04-10-2019, 11:09 PM

I would recommend you also add a heading from each source table so the summary table makes it clear where each source comes from. Otherwise the context of each paragraph is unclear eg n/a appearing in the middle of the result cell. I think it would be improved if the result followed a format like
Firearm Worksheet
blah blah
Fired Cartridge Case Worksheet
blah blah
Bullet Worksheet
blah blah

jrooney7 · #9 04-11-2019, 08:59 AM

That's a great suggestion. I changed one line of your code to

Code:

If InStr(aRng.Text, "Worksheet") > 0 And InStr(aTbl.Range.Cells(aTbl.Range.Cells.Count).Range.Text, "n/a") = 0 Then

This keeps the macro from pulling any n/a results. I've added a header to the others that were missing it, like the Comparison Results one.

In case you're interested, here is the final code I came up with. I used your code to help me format the paragraphs in the destination cell so it's much easier to read. You probably could have done it alot "prettier", but hey, it works

Code:

Sub Results2()
  Dim i As Integer, iTables As Integer
  Dim aTbl As Table, tblLast As Table, tblTgt As Table, aCellTgt As Cell
  Dim aRng As Range, aRngEnd As Range, aRngSource As Range
  
  iTables = ActiveDocument.Tables.Count
  Set tblLast = ActiveDocument.Tables(iTables)
  Set tblTgt = tblLast.Tables(2)
  Set aCellTgt = tblTgt.Cell(1, 2)
  aCellTgt.Range.Text = ""    'if you want to start with a blank cell
  
  For i = 1 To iTables - 1
    Set aTbl = ActiveDocument.Tables(i)
    Set aRng = aTbl.Range.Cells(1).Range
    If InStr(aRng.Text, "Worksheet") > 0 And InStr(aTbl.Range.Cells(aTbl.Range.Cells.Count).Range.Text, "n/a") = 0 Then
      Set aRngSource = aTbl.Range.Cells(aTbl.Range.Cells.Count).Range
      aRngSource.MoveEnd Unit:=wdCharacter, Count:=-1
      Set aRngEnd = aCellTgt.Range
      aRngEnd.Collapse Direction:=wdCollapseEnd
      aRngEnd.MoveEnd Unit:=wdCharacter, Count:=-1
      aRngEnd.FormattedText = aRngSource.FormattedText
      aRngEnd.InsertAfter vbCr & vbCr
    End If
  Next i
  tblLast.Tables(2).Cell(1, 2).Select
  With Selection.Font
    .Bold = False
    .Name = "Times New Roman"
    .Size = 10
    .ColorIndex = wdBlack
    With aCellTgt.Range
        .ParagraphFormat.SpaceAfter = 0
        .ParagraphFormat.SpaceBefore = 0
    End With
  End With
  tblLast.Tables(2).Cell(1, 2).Select
    Selection.HomeKey Unit:=wdLine
    Selection.TypeParagraph
  tblLast.Tables(2).Cell(1, 2).Select
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.Text = "Methodology"
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.Text = "The following methodologies were used in the examination of this case:"
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.Text = "Visual Examination"
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Selection.TypeParagraph
    Selection.Text = "Physical Examination"
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Selection.TypeParagraph
    Selection.Text = "Physical Measurements"
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Selection.TypeParagraph
    Selection.Text = "Microscopic Examination"
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Selection.TypeParagraph
    Selection.Text = "Microscopic Comparison"
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Selection.TypeParagraph
    Selection.Text = "Database Search"
    
  Dim p As Integer, pParagraph As Integer
  Dim r As Range
  tblLast.Tables(2).Cell(1, 2).Select
  pParagraph = Selection.Paragraphs.Count
  tblLast.Tables(2).Cell(1, 2).Range.InsertParagraphAfter
    For p = 1 To pParagraph
      Set aParagraph = tblLast.Tables(2).Cell(1, 2).Range.Paragraphs(p)
      Set aRng = aParagraph.Range
        If InStr(aRng.Text, "Result") > 0 Then
            aRng.Select
            With Selection.Font
                .Bold = True
            End With
        End If
        If InStr(aRng.Text, "Result") = 0 Then
            aRng.Select
            Selection.Paragraphs.LeftIndent = 18
        End If
        If InStr(aRng.Text, "Methodology") > 0 Then
            aRng.Select
            With Selection.Font
                .Bold = True
            End With
            Selection.Paragraphs.LeftIndent = 0
        End If
    Next p
  Selection.Document.Undo
  Selection.Paragraphs.LeftIndent = 18
  Selection.EndKey Unit:=wdLine
  Selection.MoveDown Unit:=wdLine, Count:=1
  Selection.TypeBackspace
  
End Sub

Thank you so much for your help!

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How to compile text from multiple tables into a cell in a nested table	jrooney7	Word VBA	2	03-11-2019 07:55 AM
Copying text into multiple cells at once	BIMwit	Word Tables	1	05-14-2015 09:50 PM
Ink to Text lines are different lengths	raineysky	OneNote	0	02-12-2015 11:21 AM
Copying multiple files as text without extensions	Metamag	Office	3	05-09-2011 06:25 PM
Copying Multiple tables from excel into a single word document	dineshtgs	Word Tables	1	04-07-2011 01:27 AM