Compare files in different directories, slightly different namesm,Macro doesn't loop

[lkpederson]

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