Excel vba: create folder, move Word files, Search Replace

[enigmaes]

Hi, all. Thanks in advance for looking at my project.
I have an Excel sheet that I am using for a master source of information.
Row1 (4 cols): Store Number | City | Inventory# | Item
Rows 2-xx have the data for each of the items in row 1.

Running the macro, I want this to do the following:
(works) 1. Create new folder (Sites)
(works) 2. Make new folder under "Sites" named with store number and city (taken from concatenation within Excel).
(works) 3. Copy Folders and contents: in their respective subdirectories into each store/city folder
(not even) 4. Find each Subfolder (now Sites\City\Template1, Sites\City\Template2, etc.),
4a. Open each word doc in each subfolder
4b. Search=cells(1, col).value, replace=cells(r,col).value (include header/footer)
4c. Save it, close it, and go onto the next one.

I've used msgBox to track progress - once it works, those prompts are gone.
I'm not seeing it open the second doc in a folder, I'm not seeing it open the second folder (template2, for example) to look for docs, and the search/replace isn't working.

Any help tremendously appreciated.

[CODE=vba]
Sub MakeFolders()
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim r As Integer
Dim Path As String
Dim TheFolder As String
    
On Error Resume Next

'get rows
rowr = Range("A1").End(xlDown).Row
MsgBox "there are this many rows " & rowr
    
' if directory doesn't exist, make it
    If Len(Dir(ActiveWorkbook.Path & "\Sites\", vbDirectory)) = 0 Then
        MkDir (ActiveWorkbook.Path & "\Sites\")
    End If

' make subdirectories based on concatenation happening at r, 13
For r = 2 To rowr
    If Len(Dir(ActiveWorkbook.Path & "\Sites\" & Cells(r, 13).Value, vbDirectory)) = 0 Then
        MkDir (ActiveWorkbook.Path & "\Sites\" & Cells(r, 13).Value)
        
' pull folders with word files over
        FSO.CopyFolder ActiveWorkbook.Path & "\" & "Da*", ActiveWorkbook.Path & "\Sites\" & Cells(r, 13).Value & "\"
        MsgBox "this is the folder to copy from/to " & ActiveWorkbook.Path & "\" & "Da*" & "  " & ActiveWorkbook.Path & "\Sites\" & Cells(r, 13).Value & "\"
    On Error Resume Next
        
' declare something
        TheFolder = ActiveWorkbook.Path & "\Sites\" & Cells(r, 13).Value & "\"
       
' get to all subfolders
        Set FSOLibrary = New FileSystemObject
            FindSubFolders FSOLibrary.GetFolder(TheFolder)
            MsgBox "this is the folder " & TheFolder
    End If
 Next r
End Sub
        
Sub FindSubFolders(FSOFolder As Object)

Dim FSOSubFolder As Object, FSOFile As Object, appWord As Object, objDoc As Object
Dim xlWs As Worksheet, k As Long
Set xlWs = Sheets("Site")
Set appWord = CreateObject("Word.Application")

For Each FSOSubFolder In FSOFolder.SubFolders
    FindSubFolders FSOSubFolder
Next

For Each FSOFile In FSOFolder.Files
    MsgBox "open each one" & FSOFile
    
With appWord
  .Visible = True
  Set objDoc = .Documents.Open(FSOFile)
  With objDoc.Content.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchCase = False
    .MatchWholeWord = True
    
' With document open, find placeholders in activedocument, which are row headers (row 1, col k)
' replace with stuff contained in (row r, col k)
    
    For k = 1 To 4
    On Error Resume Next
      .Text = xlWs.Cells(1, k).Value
      .Replacement.Text = xlWs.Cells(r, k).Value
      .Execute Replace:=2
    Next k
  ActiveDocument.Close ' SaveChanges:=wdSaveChanges
  End With
  .Quit
End With
On Error Resume Next
Next FSOFile
End Sub

[/CODE]