|
|
Thread Tools | Display Modes |
#31
|
|||
|
|||
I guess I don't know how to apply the code from #4 properly to the situation described in #29. I tried, but got a syntax error.
|
#32
|
|||
|
|||
Here's my complete code right now.
Haven't yet switched in the simplified table finder. When I ran it just now, it stopped on 'invalid procedure call or argument' on the 'FileName = Mid' code block. 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 Trim(.Text) Case "Revision No." .Cells(1).Next.Range.Text = "2.5" Case "Published" If .Cells(1).ColumnIndex = 1 Then .Cells(1).Next.Range.Text = "5 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 |
#33
|
||||
|
||||
From what I can tell, you don't need anything to do with Word_ExportPDF. Why do you still have that?
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#34
|
|||
|
|||
You're right, I didn't need that part.
It all seems to work right now. Thanks for your time. I may come back later and ask for help with tweaking it to do nested directories. |
#35
|
||||
|
||||
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#36
|
|||
|
|||
That seems to do the trick. Thanks for your time and patience.
|
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 |