Sub CompareAllFiles2() 
    Dim strFolder(2), SourceFolder(2), fLoc As String 
    Dim strFileSpec, strFileName As String, FileB As String 
    Dim objDocA As Word.Document 
    Dim objDocB As Word.Document 
    Dim objDocC As Word.Document 
    Dim n As Integer 
 
    strFolder(0) = "Enter path to base documents:" 
    strFolder(1) = "Enter path to new documents:" 
    strFolder(2) = "Enter path for document comparisons to be saved:" 
 
     '    For n = 0 To 2
     '        SourceFolder(n) = GetFolder(strFolder(n)) & "\"
     '    Next n
 
     ' added this for testing purposes...
    SourceFolder(0) = "c:\projects\test\01_Specifications" 
    SourceFolder(1) = "c:\projects\test\01_Specifications NEW" 
    SourceFolder(2) = "c:\projects\test\compare" 
 
    strFileSpec = "*.docx" 
    strFileName = Dir$(SourceFolder(0) & "\" & strFileSpec) 
 
    Do While strFileName <> "" 'vbNullString
        Set objDocA = Documents.Open(SourceFolder(0) & "\" & strFileName) 
        FileB = Dir$(SourceFolder(1) & "\" & Left(strFileName, 8) & "*.docx") 
 
         ' if file isn't found in new directory, make an empty file
        If Left(Dir$(SourceFolder(0) & "\" & strFileName), 8) Like _ 
        Left(FileB, 8) Then 
             '            Set objDocB = Documents.Open(SourceFolder(1) & "\" & strFileName)
            Set objDocB = Documents.Open(SourceFolder(1) & "\" & FileB) 
            Application.CompareDocuments _ 
            OriginalDocument:=objDocA, _ 
            RevisedDocument:=objDocB, _ 
            Destination:=wdCompareDestinationNew, CompareFormatting:=False, _ 
            CompareWhitespace:=False 
            objDocA.Close 
            objDocB.Close 
            Set objDocC = ActiveDocument 
            objDocC.SaveAs FileName:=SourceFolder(2) & "\" & strFileName 
            objDocC.Close SaveChanges:=True 
        Else 
            Set objDocC = Documents.Add 
            objDocC.SaveAs2 FileName:=SourceFolder(2) & "\" & Left(strFileName, 11) & _ 
            "NO DOC.docx" 
            objDocC.Close 
            objDocA.Close 
 
        End If 
 
        strFileName = Dir 
    Loop 
    Set objDocA = Nothing 
    Set objDocB = Nothing 
End Sub 
 
 
Function GetFolder(strFolder) As String 
    Dim oFolder As Object 
    GetFolder = "" 
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, strFolder, 0) 
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.ItemS.Item.Path 
    Set oFolder = Nothing 
End Function