Situation: Two different directories with containing files where:

1. file names may vary slightly but the first 8 characters WILL match.
2. Some files *may* be in one directory but not the other.
3. If a file is missing, make it a blank file as a placeholder.

I trolled around and found a macro for comparing multiple files in different directories but the file names had to match. Edited it and voila! now it doesn't loop.

Yes the directories contain more than one file. Suggestions?

TIA.

    
    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