VBA to open all docs in a folder and replace text

[psymson]

Hi there

I have been given the following VBA code:

Option Explicit
Global sRootSite As String
Global myFSO As FileSystemObject, rngFileList As Range
Sub GetFileDetailsFromSharepoint()
ThisWorkbook.Activate
Worksheets("Sheet2").Activate
Set rngFileList = ThisWorkbook.Worksheets("Sheet2").Range("A1")
    rngFileList = "aFile.Path"
    rngFileList.Offset(0, 1) = "aFile.Name"
    rngFileList.Offset(0, 2) = "aFile.ParentFolder"
    rngFileList.Offset(0, 3) = "aFile.Type"
    rngFileList.Offset(0, 4) = "aFile.Size"
    rngFileList.Offset(0, 5) = "aFile.DateCreated"
    rngFileList.Offset(0, 6) = "aFile.DateLastAccessed"
    rngFileList.Offset(0, 7) = "aFile.DateLastModified"
    rngFileList.Offset(0, 8) = "aFile.Attributes"
    
   
    rngFileList.Activate
Set myFSO = New FileSystemObject
'sRootSite = "//teamspace.intranet.group/sites/cosbo/New%20Binder%20Build"
sRootSite = "C:\Documents and Settings\7594475\My Documents"
AddFilesInFolderToFileList True
ThisWorkbook.Save
Exit Sub
Stop
SearchForTextInWordDocs
SearchForTextInVisioDrawings
End Sub
Private Sub AddFilesInFolderToFileList(Optional AndSubFolders As Boolean, Optional FromWhichFolder As String)
Dim myFolder As Folder, aSubFolder As Folder, aFile As File
On Error Resume Next
FromWhichFolder = IIf(Left(FromWhichFolder, 2) = "\\", "", sRootSite) & IIf(InStr(1, FromWhichFolder, "\") = 0, "\", "") & FromWhichFolder
Set myFolder = myFSO.GetFolder(FromWhichFolder)
For Each aFile In myFolder.Files
    Set rngFileList = rngFileList.Offset(1, 0)
    rngFileList.Activate
    rngFileList = aFile.Path
    rngFileList.Offset(0, 1) = aFile.Name
    rngFileList.Offset(0, 2) = aFile.ParentFolder
    rngFileList.Offset(0, 3) = aFile.Type
    rngFileList.Offset(0, 4) = aFile.Size
    rngFileList.Offset(0, 5) = aFile.DateCreated
    rngFileList.Offset(0, 6) = aFile.DateLastAccessed
    rngFileList.Offset(0, 7) = aFile.DateLastModified
    rngFileList.Offset(0, 8) = aFile.Attributes
Next aFile
If AndSubFolders Then
    For Each aSubFolder In myFolder.SubFolders
        If aSubFolder.Name = "Forms" _
            Or aSubFolder.Name = "Archive" _
            Or aSubFolder.Name = "Archived" _
            Or aSubFolder.Name = "Archive2" _
            Then
        Else
            ThisWorkbook.Save
            AddFilesInFolderToFileList AndSubFolders, aSubFolder.Path
        End If
    Next
End If
End Sub

Sub SearchForTextInWordDocs()

Dim myWord As Word.Application, wordDoc As Word.Document
Dim iCol As Integer, bFoundText As Boolean
Set myWord = New Word.Application
myWord.Visible = True
Set myFSO = New FileSystemObject
Set rngFileList = ThisWorkbook.Worksheets("Sheet2").Range("A2")
On Error GoTo ErrHandler
'this is where you need to change where to save the temp files. There are 3 locations here that you need to change.
Do Until rngFileList = ""
    If rngFileList.Offset(0, 3) = "Microsoft Office Word Document" Then
        myFSO.CopyFile rngFileList, "C:\Documents and Settings\7594475\My Documents\Test\", True
        Set wordDoc = myWord.Documents.Open("C:\Documents and Settings\7594475\My Documents\Test\" & rngFileList.Offset(0, 1), False, False, False)
        myWord.Caption = rngFileList.Row - 1 & " - " & Format(Now, "hh:mm:ss")
            rngFileList.Activate
            
            bFoundText = False
            
            For iCol = 10 To 20
                rngFileList.Offset(0, iCol) = wordDoc.Content.Find.Execute(FindText:=Cells(1, iCol + 1), ReplaceWith:=Cells(1, iCol + 12), MatchWholeWord:=True, Replace:=wdReplaceAll)
                If rngFileList.Offset(0, iCol) Then bFoundText = True
            Next
            
            If bFoundText Then
                wordDoc.Close True
            Else
                wordDoc.Close False
                Kill "C:\Documents and Settings\7594475\My Documents\Test\" & rngFileList.Offset(0, 1)
            End If
RestartAfterSkip:
    End If
Set rngFileList = rngFileList.Offset(1, 0)
Loop
ThisWorkbook.Save
Exit Sub
ErrHandler:
Resume RestartAfterSkip
End Sub
Sub SearchForTextInVisioDrawings()
Dim myVisio As Visio.Application, visioDoc As Visio.Document, visioPage As Visio.Page, visioShape As Visio.Shape
Dim iCol As Integer, bFoundText As Boolean
Set myVisio = New Visio.Application
myVisio.Visible = True
Set myFSO = New FileSystemObject
Set rngFileList = ThisWorkbook.Worksheets("BinderFiles").Range("A2")
On Error GoTo ErrHandler
Do Until rngFileList = ""
rngFileList.Activate
    If rngFileList.Offset(0, 3) = "Microsoft Visio Drawing" Then
        myFSO.CopyFile rngFileList, "C:\Documents and Settings\7594475\My Documents\Test\", True
        Set visioDoc = myVisio.Documents.Open("C:\Documents and Settings\7594475\My Documents\Test\" & rngFileList.Offset(0, 1))
        bFoundText = False
        
        For iCol = 10 To 20
            For Each visioPage In visioDoc.Pages
                For Each visioShape In visioPage.Shapes
                    If rngFileList.Offset(0, iCol) = 0 Then
                        rngFileList.Offset(0, iCol) = InStr(1, visioShape.Text, Cells(rngFileList.Row, 1))
                        bFoundText = True
                    End If
                Next
            Next
        Next
            
        If bFoundText Then
            visioDoc.SaveAs "C:\Documents and Settings\7594475\My Documents\Test\" & Left(rngFileList.Offset(0, 1), Len(rngFileList.Offset(0, 1)) - 4) & Format(Date, "yyyymmdd") & ".vsd"
            visioDoc.Close
        Else
            visioDoc.Saved = True '.SaveAs "C:\Documents and Settings\7594475\My Documents\Test\" & Left(rngFileList.Offset(0, 1), Len(rngFileList.Offset(0, 1)) - 4) & Format(Date, "yyyymmdd") & ".vsd"
            visioDoc.Close
        End If
RestartAfterSkip:
    End If
Set rngFileList = rngFileList.Offset(1, 0)
Loop
ThisWorkbook.Save
Exit Sub
ErrHandler:
'Resume RestartAfterSkip
If Err.Number = 53 Or Err.Number = 76 Then Resume RestartAfterSkip
Resume Next
End Sub
Sub GetDataFromExcelFiles()
Set rngFileList = ThisWorkbook.Worksheets("Sheet2").Range("A2")
On Error GoTo ErrHandler
Do Until rngFileList = ""
    If rngFileList.Offset(0, 1) Like "2014*" Then
    Workbooks.Open rngFileList
    If Range("A1") = "" Then
    ActiveWorkbook.Worksheets("IEHistory").Range("A1").CurrentRegion.Offset(1, 0).Copy ThisWorkbook.Worksheets("SpiderData4").Range("A1").Offset(ThisWorkbook.Worksheets("SpiderData4").Range("A1").CurrentRegion.Rows.Count, 0)
    End If
    ActiveWorkbook.Close False
    End If
If ThisWorkbook.Worksheets("SpiderData4").Range("A1").CurrentRegion.Rows.Count > 60000 Then
    Stop
End If
ResumeNext:
Set rngFileList = rngFileList.Offset(1, 0)
rngFileList.Interior.Color = vbYellow
Loop
ThisWorkbook.Save
Exit Sub
ErrHandler:
'Stop
If ActiveWorkbook.Name Like "2014*" Then ActiveWorkbook.Close False
Resume ResumeNext
End Sub

It was written by someone who has left the business and passed to a colleage, he get get it to run using his My Documents Folder but not from the sharepoint.

Apparently he needs to run trhough all the docs on the sharepoint (work, Visio & Excel) then find and replace certain words.

I have just opened it on my PC, and changed the links to My Ducuments, but I keep getting erros,

Any Ideas???


Many thanks

Andy