#1
|
|||
|
|||
Find and Replace rows in a table based on bold text.
Hi, I am completely new to VBA, so I apologize for any errors/formatting issues.
Basically, I want this program to do this: 1. Search and find a bold keyword (1st category heading) 2. Find the next bold word after (the next category heading) 3. Copy all rows in between the two categories 4. Paste rows in another document (under the 1st category heading) Here is the code I have so far: Code:
Const myKeyTerms As String = _ "Aerospace, Space & Defence" Dim myTable As Table Dim myRow As Row Dim myRange As Range Dim myRange2 As Range Dim myTable2 As Table Dim myRow2 As Row Documents.Open ("") For Each myTable In ActiveDocument.Tables For Each myRow In myTable.Rows ' If successful myrange is moved to the found text Set myRange = myRow.Range ' Search parameters are persistent so you only need to change them if the search parameters change With myRange.Find .Font.Bold = True .Text = "" .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .Wrap = wdFindStop .Forward = True ' Stop when the range is searched ' .Execute returns true if the search is found Do While .Execute ' myRange is now the found term myRange.Select If InStr(myKeyTerms, myRange.Text) > 0 Then 'Actions to do if the row contained a key term in bold myRange.Copy ThisDocument.Activate For Each myTable2 In ActiveDocument.Tables For Each myRow2 In myTable2.Rows ' If successful myrange is moved to the found text Set myRange2 = myRow2.Range ' Search parameters are persistent so you only need to change 'them if the search parameters change With myRange2.Find .Font.Bold = True .Text = "" .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .Wrap = wdFindStop .Forward = True ' Stop when the range is searched ' .Execute returns true if the search is found Do While .Execute ' myRange is now the found term myRange2.Select If InStr(myKeyTerms, myRange2.Text) > 0 Then Selection.PasteAndFormat (wdTableInsertAsRows) Exit Sub End If ' reset myRange to encompass the rest of the row myRange2.Start = myRange2.End + 1 myRange2.End = myRow2.Range.End myRange2.Select Loop End With Next myRow2 Next myTable2 End If ' now we need to reset myRange to encompass the rest of the row myRange.Start = myRange.End + 1 myRange.End = myRow.Range.End myRange.Select Loop End With Next myRow Next myTable End Sub |
#2
|
||||
|
||||
Without the tables, it is impossible to test against what you have, but the following should be close
Code:
Option Explicit Sub Macro1() 'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jul 2017 Const myKeyTerms As String = _ "Aerospace, Space & Defence" Dim oDoc As Document Dim oTarget As Document Dim oTable As Table Dim oRng As Range Dim oNew As Range Dim oCell As Cell Set oDoc = ActiveDocument Set oTarget = Documents.Add oTarget.Range.Text = myKeyTerms & vbCr oTarget.Paragraphs(1).Range.Font.Bold = True If oDoc.Tables.Count = 0 Then MsgBox "No tables in this document?" GoTo lbl_Exit End If For Each oTable In oDoc.Tables Set oRng = oTable.Range With oRng.Find Do While .Execute(FindText:=myKeyTerms) If oRng.InRange(oTable.Range) Then If oRng.Font.Bold = True Then oRng.Start = oRng.Rows(1).Range.Next.Rows(1).Range.Start oRng.End = oTable.Range.End For Each oCell In oRng.Cells If oCell.Range.Font.Bold = True Then oRng.End = oCell.Range.Start Exit For End If Next oCell Exit Do End If End If oRng.Collapse 0 Loop End With Set oNew = oTarget.Range oNew.Collapse 0 oNew.FormattedText = oRng.FormattedText Next oTable lbl_Exit: Set oDoc = Nothing Set oTarget = Nothing Set oRng = Nothing Set oNew = Nothing Set oTable = Nothing Set oCell = Nothing Exit Sub End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
Sorry, I was out of the office for the weekend, but I am back now. Your code almost works, but I think I didn't explain myself clearly enough the first time.
Master Document: The place I want to input all the new data. Source Document: Where all the new data is drawn from. Here is what my tables look like: Source Document: Row1: "Aerospace, Space & Defence" Row2: New Data Row3: New Data Row4: "Agri Foods" I want to copy all the data in between the two headings. Then: Master Document: Row1: "Aerospace, Space & Defence" Row2: Old Data Row3: "Agri Foods" I want to paste the new data and replace the old data. Note that the number of rows under each heading varies. Any help would be greatly appreciated! Thanks so much. |
#4
|
||||
|
||||
As I said before, without the documents, this type of process is impossible to test. There is there is simply too much potential for error to waste the time programming something that may not work, and then start over to try something else. I give a lot of my spare time to helping users with their programming problems, as do a number of fellow contributors, but we don't relish that time being wasted.
My last message included code that worked on the premise that the extracted code was to be written to a new document. Now it appears that you want to write the data to another document that already has data which is different from the first document. For example, does that second document have the same number of tables. Is the data in the first document going in the same numbered table in the second document. There is too much scope for ambiguity.
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#5
|
|||
|
|||
Maybe I didn't make myself clear enough. Each week I am given varying amounts of information under predetermined headings. Right now, I have to copy and paste each row individually. What I am trying to do is take all the rows under each heading in the source document, and paste them under the headings in the master document. I do appreciate the effort that individuals such as yourself put into helping less capable coders such as me.
I have already written code (with help from others on this forum) to do error handling in case that there is a new heading that is not among the predetermined ones. It might help explain what I am trying to do. Code:
Const myKeyTerms As String = _ "OrganizationDate+Description+Aerospace, Space & Defence+Automotive+Manufacturing+Life Sciences+Information Communication Technologies / Digital+Natural Resources / Energy+Regional Stakeholders+Other Policy Priorities+NIL+Nil+nil" Dim i As Integer Dim myTable As Table Dim myFirstRange As Range Dim mySecondRange As Range Dim myRemoveRange As Range Dim SecondRangeFlag As Boolean i = ThisDocument.Tables.Count Documents.Open ("") For Each myTable In ActiveDocument.Tables Set myFirstRange = Nothing SecondRangeFlag = False Do If myFirstRange Is Nothing Then Set myFirstRange = fnFindBold(mySearchRange:=myTable.Range.Rows(1).Range) Else Set myFirstRange = fnFindBold(mySearchRange:=myFirstRange.Next(Unit:=wdRow)) End If ' two possible cases for myFirstrange ' 1. a found range ' 2. nothing - which means we have searched the whole table. If Not myFirstRange Is Nothing Then If InStr(myKeyTerms, myFirstRange.Text) = 0 Then ' Found bold text that is not a defined category (key term) Set mySecondRange = myFirstRange.Duplicate Do Set mySecondRange = fnFindBold(mySecondRange.Next(Unit:=wdRow)) If mySecondRange Is Nothing Then SecondRangeFlag = True Else If InStr(myKeyTerms, mySecondRange.Text) > 0 Then SecondRangeFlag = True End If End If Loop Until SecondRangeFlag 'We have now found text that is a defined category key term Set myRemoveRange = myFirstRange.Duplicate If mySecondRange Is Nothing Then myRemoveRange.End = myTable.Range.End Set myFirstRange = Nothing Else myRemoveRange.End = mySecondRange.Previous(Unit:=wdRow).End Set myFirstRange = mySecondRange End If myRemoveRange.Select myRemoveRange.Copy ThisDocument.Tables(i).Select Selection.Collapse Direction:=wdCollapseEnd Selection.PasteAndFormat (wdTableInsertAsRows) i = i + 1 Documents("").Activate ActiveDocument.Tables(1).Select Selection.Collapse Direction:=wdCollapseEnd Selection.PasteAndFormat (wdTableInsertAsRows) myRemoveRange.Select myRemoveRange.Cut End If End If Loop Until myFirstRange Is Nothing Next myTable End Sub |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Macro to find and replace headings in bold and underline | redzan | Word VBA | 4 | 02-13-2016 12:24 PM |
Find, select, and replace part of text with bold | paik1002 | Word VBA | 4 | 12-07-2015 11:24 PM |
VBA Table – Search All Tables - Find & Replace Text in Table Cell With Specific Background Color | jc491 | Word VBA | 8 | 09-30-2015 06:10 AM |
find and replace in bold | redzan | Word VBA | 1 | 07-27-2014 03:35 PM |
Word VBA Macro to Find and Replace based on the Alt Text of an Image | bennymc | Word VBA | 1 | 01-27-2014 04:23 PM |