Consulting

Results 1 to 3 of 3

Thread: how to accept all changes in folders and subfolders

  1. #1

    how to accept all changes in folders and subfolders

    I am trying to refresh my VBA Skills and our company has disabled many functions in Word 2016.

    The code below works, but I can't get it to do subfolders as well, any suggestions are much appriciated in advance. Additionally, if you know how to easily addin 'deleteallcomment' that would be incredible.
    Sub UpdateDocuments()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document, Rng As Range
    strDocNm = ActiveDocument.FullName
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    While strFile <> ""
      If strFolder & "" & strFile <> strDocNm Then
        Set wdDoc = Documents.Open(FileName:=strFolder & "" & strFile, AddToRecentFiles:=False, Visible:=False)
        With wdDoc
          For Each Rng In .StoryRanges
            Rng.Revisions.AcceptAll
          Next
          .Close SaveChanges:=True
        End With
      End If
      strFile = Dir()
    Wend
    Set wdDoc = Nothing
    Application.ScreenUpdating = True
    End Sub
    Last edited by macropod; 11-28-2018 at 08:25 PM. Reason: Added code tags & formatting

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,672
    Location
    Before your 'UpdateDocuments' sub, insert:
    Dim FSO As Object, oFolder As Object, StrFolds As String
     
    Sub Main()
    Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
    TopLevelFolder = GetFolder
    StrFolds = vbCr & TopLevelFolder
    If FSO Is Nothing Then
      Set FSO = CreateObject("Scripting.FileSystemObject")
    End If
    'Get the sub-folder structure
    Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
    For Each aFolder In TheFolders
      RecurseWriteFolderName (aFolder)
    Next
    'Process the documents in each folder
    For i = 1 To UBound(Split(StrFolds, vbCr))
      Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
    Next
    End Sub
     
     
    Sub RecurseWriteFolderName(aFolder)
    Dim SubFolders As Variant, SubFolder As Variant
    Set SubFolders = FSO.GetFolder(aFolder).SubFolders
    StrFolds = StrFolds & vbCr & CStr(aFolder)
    On Error Resume Next
    For Each SubFolder In SubFolders
      RecurseWriteFolderName (SubFolder)
    Next
    End Sub
    Change your 'UpdateDocuments' sub's name from:
    Sub UpdateDocuments()
    to:
    Sub UpdateDocuments(oFolder As String)
    and change its line:
    strInFolder = GetFolder
    to:
    strInFolder = oFolder

    With the above changes, you now run the 'Main' sub.
    Cheers
    Paul Edstein
    [MS MVP - Word]

  3. #3

    Cool AMAZING....THANKS works perfect.

    'Before your 'UpdateDocuments' sub, insert:"
    This has saved me so much time!

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •