#1
|
|||
|
|||
Copying text from last row of multiple tables of different lengths
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 |
#2
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
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!
|
#4
|
||||
|
||||
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.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#5
|
|||
|
|||
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! |
#6
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#7
|
|||
|
|||
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!!
|
#8
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#9
|
|||
|
|||
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 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 |