View Single Post
 
Old 03-01-2013, 01:53 PM
dmarie123 dmarie123 is offline Windows 7 64bit Office 2007
Novice
 
Join Date: Dec 2012
Location: New Yuk
Posts: 23
dmarie123 is on a distinguished road
Default adding code, not working

Hi,

Question 1: I'm working on combining some of the macros that all of you have provided/helped me with (thank you again Greg and Paul ). I've tried adding code to Sub BulkFindReplace (code posted below) so that it will apply the following formatting to all the word docs (.docx) in the folder:
Align "left"
Arial Font
size 11

I've tried putting the code in multiple places using wdDoc and range. I was able to make it work a couple times but then couldn't replicate it. I don't understand why it would work once and then not again. I've used the following:

Code:
Selection.WholeStory
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
Selection.Font.Size = 11
Selection.Font.Name = "Arial"
Question 2: Also, if I do decide to turn track changes on for a folder of .docx folders (MS Word 2007) how would I do that? Again, I was able to make it work a few times, I'm assuming the "activeDocument" part is what prevents it from applying track changes to all the documents. The code I wrote either didn't work again or didn't work on all of them.

Question 3:
Code:
'Add to Student ID
    .Text = "SID[:][ ][ ]{1,2}[0-9]{10}"
    .Replacement.Text = "^& (Approved: / / )"
    .Execute Replace:=wdReplaceAll
When I run the above section in the other macro it works great but when I add it to Sub BulkFindReplace below it goes crazy. By crazy I mean it adds the "(Approved: / / )" part about twenty times. In keeping with my theme thus far, I can make it work "crazy" or not at all????

Please help, I'm thoroughly and completely confused.

Code:
Sub BulkFindReplace()
Application.ScreenUpdating = True

Dim strFolder As String, strFile As String, wdDoc As Document
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean
Dim xlFList As String, xlRList As String, i As Long, Rslt

StrWkBkNm = "C:\Documents" & "\MACRO.xls"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
'Get the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
' Test whether Excel is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Excel, so we can close it later.
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  If xlApp Is Nothing Then
    MsgBox "Can't start Excel.", vbExclamation
    Exit Sub
  End If
  ' Record that we've started Excel.
  bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With xlApp
  'Hide our Excel session
  If bStrt = True Then .Visible = False
  For Each xlWkBk In .Workbooks
    If xlWkBk.FullName = StrWkBkNm Then ' It's open
      Set xlWkBk = xlWkBk
      bFound = True
      Exit For
    End If
  Next
  ' If not open by the current user.
  If bFound = False Then
    ' Check if another user has it open.
    If IsFileLocked(StrWkBkNm) = True Then
      ' Report and exit if true
      MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
      If bStrt = True Then .Quit
      Exit Sub
    End If
    ' The file is available, so open it.
    Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm)
    If xlWkBk Is Nothing Then
      MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
      If bStrt = True Then .Quit
      Exit Sub
    End If
  End If
  ' Process the workbook.
  With xlWkBk.Worksheets(StrWkSht)
    ' Find the last-used row in column A.
    ' Add 1 to get the next row for data-entry.
    iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
    ' Output the captured data.
    For i = 1 To iDataRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & i)) <> vbNullString Then
        xlFList = xlFList & "|" & Trim(.Range("A" & i))
        xlRList = xlRList & "|" & Trim(.Range("B" & i))
      End If
    Next
  End With
  If bFound = False Then xlWkBk.Close False
  If bStrt = True Then .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
' Process each document in the folder
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    
  ' Process each word doc from the F/R List
  For i = 1 To UBound(Split(xlFList, "|"))
    With wdDoc.Range
        With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWholeWord = True
        .MatchCase = True
        .Wrap = wdFindStop
        .Text = Split(xlFList, "|")(i)
        .Replacement.Text = Split(xlRList, "|")(i)
        .Execute Replace:=wdReplaceAll
        End With
      End With
         
' Add "-" to IDs, Add “(Approved: / / )”, Change Dates to Long Format

With wdDoc.Range
   With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True

     'Add to SID
    .Text = "SID[:][ ][ ]{1,2}[0-9]{10}"
    .Replacement.Text = "^& (Approved: / / )"
    .Execute Replace:=wdReplaceAll
    
    'Fix IDs Part 1
    .Text = "(ID[:][ ][ ]{1,2}[0-9]{2})([0-9]{7})"
    .Replacement.Text = "\1-\2"
    .Execute Replace:=wdReplaceAll
       
    'Fix IDs Part 2
    .Text = "(ID[ ]{1,2}[0-9]{2})([0-9]{7})"
    .Replacement.Text = "\1-\2"
    .Execute Replace:=wdReplaceAll
    
    'Fix Date ranges
    .Text = "[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}-[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}"
    .Replacement.Text = ""
    .Execute
    
  End With
  Do While .Find.Found
    StrTxt = Format(Trim(Split(.Text, "-")(0)), "MMMM D, YYYY")
    Select Case Trim(LCase(.Words.First.Previous.Previous.Words.First))
      Case "between": StrTxt = StrTxt & " and "
      Case "from": StrTxt = StrTxt & " to "
      Case "of": StrTxt = StrTxt & " through "
    End Select
    StrTxt = StrTxt & Format(Trim(Split(.Text, "-")(1)), "MMMM D, YYYY")
    .Text = StrTxt
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
  End With
  Next
  'Close the document
  wdDoc.Close SaveChanges:=True
  'Get the next document
  strFile = Dir()
Wend
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
Function IsFileLocked(strFileName As String) As Boolean
  On Error Resume Next
  Open strFileName For Binary Access Read Write Lock Read Write As #1
  Close #1
  IsFileLocked = Err.Number
  Err.Clear
End Function
Thank you (again) for your time.
-Donna
Reply With Quote