Microsoft Office Forums - View Single Post - Compare files in different directories, slightly different namesm, Macro doesn't loop

lkpederson · 04-28-2015, 01:32 PM

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.

Code:

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