|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
find and replace a number that's always in a table and always adjacent to a cell with known text
I have a series of documents that all contain identical formatting.
Each has a table that contains a cell with the value "Revision No." Then, in the cell just to the right of that first cell, there is another cell, containing a number. So it looks kind of like this: Revision No. 6 Except that "Revision No." and "6" are in different cells. So, I need to programatically (because there are many documents) update the numbers. I don't want to do a normal find and replace because, of course, the number 6 might occur in other places throughout the document, and I don't want to replace those. I only want to replace the one that represents the revision number. If this is too hard, then there might be other ways to identify the exact cell where the revision number occurs. It does tend to be in the same position, relative to the whole table, in every document. However, I am not 100% sure that there are no exceptions. |
#2
|
||||
|
||||
It's probably best to look for 'Revision No.' in tables, then update the next cell. The following code, for example, does that for all documents in a folder:
Code:
Sub UpdateDocuments() Application.ScreenUpdating = False Dim strFolder As String, strFile As String, wdDoc As Document strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.doc", vbNormal) While strFile <> "" Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDoc With .Range With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "Revision No." .Replacement.Text = "" .Forward = True .Format = False .Wrap = wdFindStop End With Do While .Find.Execute If .Information(wdWithInTable) = True Then .Cells(1).Next.Range.Text = "6" .Collapse wdCollapseEnd Loop End With .Close SaveChanges:=True End With strFile = Dir() Wend Set wdDoc = Nothing Application.ScreenUpdating = True End Sub Function GetFolder() As String Dim oFolder As Object GetFolder = "" Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0) If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path Set oFolder = Nothing End Function
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
can we add export to PDF funtionality?
Thanks, macropod, this is perfect.
I actually also need to convert each document to a PDF, saving over any PDFs that are already there with the same names. In order to do this, I tried to just modify your code like so. I added: Code:
Word_ExportPDF Code:
.Close SaveChanges:=True Which would call this:
|
#4
|
||||
|
||||
Simply change:
Code:
.Close SaveChanges:=True Code:
.SaveAs FileName:=Split(.FullName, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False .Close SaveChanges:=False
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
Thanks. This seems to work great.
Just curious. Why are we changing SaveChanges to False? Don't we still want to save changes? Also, what if the files were in nested folders? Is there a way to have the option to point this at a folder full of other folders? |
#6
|
|||
|
|||
I have to take back my statement that it works great. It's only updating the PDFs.
The Word files are staying the same. That's not the intended behavior... |
#7
|
||||
|
||||
In that case, change:
Code:
.Close SaveChanges:=False Code:
.Close SaveChanges:=True
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#8
|
|||
|
|||
Thanks. This appears to work very well.
It would still be nice to apply this to nested folders, but I guess I might be able to adapt the code you wrote for me in the other thread (157036) to do that. |
#9
|
||||
|
||||
I didn't write the code to process nested folders because that's not what you asked for. By comparing the code in this thread with that of your other thread, it should be apparent how the code in this thread could be adapted to process nested folders.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#10
|
|||
|
|||
I have a follow-up to this. Perhaps macropod will see it and be kind enough to comment.
I have a cell that contains the text "Published". I want to update the cell just to the right of it. Unfortunately, there is another cell in the same table that also says "Published." In that case, it's a key, not a value, so I don't want it updated. In other words: first row : | published| jan 1, 2021 | second row: | status | published | third row: | type | ABC | What I want to do here is to change the date. So basically, I want to find the cell in the leftmost column with the word "Published" in it, and then I want to do an offset of (0,1) to go one cell to the right, and change the value there. If there's another way to think about this, then I can provide more information. For example, I could name the coordinates of each cell involved. They will always be the same. |
#11
|
||||
|
||||
You could edit the code in post #2, changing:
Code:
.Text = "Revision No." Code:
.MatchWildcards = True .Text = "[PR][eu][bv][ils]{3}[ehno]{2}[ Ndo]{1,3}" Code:
If .Information(wdWithInTable) = True Then .Cells(1).Next.Range.Text = "6" Code:
If .Information(wdWithInTable) = True Then Select Case .Text Case "Revision No." .Cells(1).Next.Range.Text = "6" Case "Published " If .Cells(1).ColumnIndex = 1 Then .Cells(1).Next.Range.Text = Format(Now, "DDD, D MMM YYYY") End If End Select End If
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#12
|
|||
|
|||
not updating
It's still not updating the right cell, actually.
In case it matters: These tables have two columns and four rows. There may be some edge cases where the number of rows varies, so I would rather not key the replacement to the exact cell, but that could be worked out if necessary. Here's what I'm using: Code:
Sub UpdateDocuments() Application.ScreenUpdating = False Dim strFolder As String, strFile As String, wdDoc As Document strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.doc", vbNormal) While strFile <> "" Set wdDoc = Documents.Open(FileName:=strFolder & "" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDoc With .Range With .Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = True .Text = "[PR][eu][bv][ils]{3}[ehno]{2}[ Ndo]{1,3}." .Replacement.Text = "" .Forward = True .Format = False .Wrap = wdFindStop End With Do While .Find.Execute If .Information(wdWithInTable) = True Then Select Case .Text Case "Revision No." .Cells(1).Next.Range.Text = "2.5" Case "Published" If .Cells(1).ColumnIndex = 1 Then .Cells(1).Next.Range.Text = "2 April 2021" End If End Select End If .Collapse wdCollapseEnd Loop End With Word_ExportPDF .SaveAs FileName:=Split(.FullName, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False .Close SaveChanges:=True End With strFile = Dir() Wend Set wdDoc = Nothing Application.ScreenUpdating = True End Sub Function GetFolder() As String Dim oFolder As Object GetFolder = "" Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0) If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path Set oFolder = Nothing End Function Sub Word_ExportPDF() 'PURPOSE: Generate A PDF Document From Current Word Document 'NOTES: PDF Will Be Saved To Same Folder As Word Document File 'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault Dim CurrentFolder As String Dim FileName As String Dim myPath As String Dim UniqueName As Boolean UniqueName = False 'Store Information About Word File myPath = ActiveDocument.FullName CurrentFolder = ActiveDocument.Path & "" FileName = Mid(myPath, InStrRev(myPath, "") + 1, _ InStrRev(myPath, ".") - InStrRev(myPath, "") - 1) 'Does File Already Exist? 'If so, too bad ' Do While UniqueName = False ' DirFile = CurrentFolder & FileName & ".pdf" ' If Len(Dir(DirFile)) <> 0 Then ' UserAnswer = MsgBox("File Already Exists! Click " & _ ' "[Yes] to override. Click [No] to Rename.", vbYesNoCancel) ' If UserAnswer = vbYes Then UniqueName = True ' ElseIf UserAnswer = vbNo Then ' Do ' 'Retrieve New File Name ' FileName = InputBox("Provide New File Name " & _ ' "(will ask again if you provide an invalid file name)", _ ' "Enter File Name", FileName) 'Exit if User Wants To ' If FileName = "False" Or FileName = "" Then Exit Sub ' Loop While ValidFileName(FileName) = False ' Else ' Exit Sub 'Cancel ' End If ' Else ' UniqueName = True ' End If ' Loop 'Save As PDF Document On Error GoTo ProblemSaving ActiveDocument.ExportAsFixedFormat _ OutputFileName:=CurrentFolder & FileName & ".pdf", _ ExportFormat:=wdExportFormatPDF On Error GoTo 0 'Confirm Save To User With ActiveDocument FolderName = Mid(.Path, InStrRev(.Path, "") + 1, Len(.Path) - InStrRev(.Path, "")) End With ' MsgBox "PDF Saved in the Folder: " & FolderName Exit Sub 'Error Handlers ProblemSaving: MsgBox "There was a problem saving your PDF. This is most commonly caused" & _ " by the original PDF file already being open." Exit Sub End Sub |
#13
|
||||
|
||||
When the Find data are as specified by you (i.e. 'Revision No.' or 'Published' in column 1), the code works for me, updating the cell in column 2.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#14
|
|||
|
|||
For me, it updates the revision number but not the publication date.
The word "Published" does seem to have a space after it in my tables. I tried adding a space after the search term, but it didn't seem to make any difference. |
#15
|
||||
|
||||
Change:
.Text = "[PR][eu][bv][ils]{3}[ehno]{2}[ Ndo]{1,3}." to: .Text = "[PR][eu][bv][ils]{3}[ehno]{2}[ Ndo]{1,3}" and change: Case "Published" to: Case "Published "
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Tags |
tables, vba, vba find and replace |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Find and Replace rows in a table based on bold text. | OfficeAssociate99 | Word VBA | 2 | 07-26-2017 06:32 AM |
Select Cell Text to paste into Find/Replace | CBarry | Word VBA | 2 | 02-16-2017 04:37 AM |
Increase number in cell, based on value in adjacent cell | scottyb | Excel | 3 | 02-02-2017 03:51 AM |
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 |
Word VBA Find Table Text Shading Colour and replace with another | QA_Compliance_Advisor | Word VBA | 10 | 09-19-2014 08:36 AM |