Filesearch replacement for

QuestionEdit

I have the below code for vbabut I don't know how to search subfolders?

Option Explicit Sub massprotect()

' ' massprotect Macro '

' Dim oWbk As Workbook Dim sFile As String Dim sPath As String

ChDrive sPath

Application.DisplayAlerts = False sPath = "I:\GEN_ACCT\Levi Only Stores (LOS)\2009\LOS Journals\cost center reporting\" 'location of files

.LookIn = sPath

   .SearchSubFolders = False

ChDrive sPath ChDir sPath

sFile = "" sFile = Dir("*.xls*") 'change or add formats Do While sFile <> "" 'will start LOOP until all files in folder sPath have been looped through

Set oWbk = Workbooks.Open(sPath & "\" & sFile) 'opens the file

ActiveWorkbook.SaveAs Filename:= _

       sPath & sFile _
       , FileFormat:=xlExcel8, Password:="", WriteResPassword:="SAPFICO", _
       ReadOnlyRecommended:=True, CreateBackup:=False
   

oWbk.Close True 'close the workbook, saving changes

sFile = Dir Loop ' End of LOOP End Sub

AnswerEdit

this should do what you want. put this code in a new module. Watch the wordwrap.

Option Base 1 Dim aFiles() As String, iFile As Integer

Sub MassProtect()

Dim Counter As Integer
iFile = 0
ListFilesInDirectory "I:\GEN_ACCT\Levi Only Stores (LOS)\2009\LOS Journals\cost center reporting\"

For Counter = 1 To iFile
  sName = aFiles(Counter)
  on Error Resume Next
  Set bk = Workbooks.Open(sName)
  if err.Number <> 0 then
     msgbox "Problems with " & sName
  Else
  Application.DisplayAlerts = False
  bk.SaveAs Filename:=sName, _
      FileFormat:=xlExcel8, _
      Password:="", _
      WriteResPassword:="SAPFICO", _
      ReadOnlyRecommended:=True, _
      CreateBackup:=False
  Application.DisplayAlerts = True
  bk.Close SaveChanges:=False  ' the book has already been
                                'saved, no use doing it again
  end if
  On Error goto 0

Next End Sub

Sub ListFilesInDirectory(Directory As String)

Dim aDirs() As String, iDir As Integer, stFile As String

' use Dir function to find files and directories in Directory
' look for directories and build a separate array of them
' note that Dir returns files as well as directories when vbDirectory
'  specified
iDir = 0
stFile = Directory & Dir(Directory & "*.*", vbDirectory)
Do While stFile <> Directory
  If Right(stFile, 2) = "\." Or Right(stFile, 3) = "\.." Then
    ' do nothing - GetAttr doesn't like these directories
  ElseIf GetAttr(stFile) = vbDirectory Then
    ' add to local array of directories
    iDir = iDir + 1
    ReDim Preserve aDirs(iDir)
    aDirs(iDir) = stFile
  Else
    ' add to global array of files if it is anworkbook
   if instr(1,stFile,".xls",vbTextcompare) > 0 then
    iFile = iFile + 1
    ReDim Preserve aFiles(iFile)
    aFiles(iFile) = stFile
   End if
  End If
  stFile = Directory & Dir()

Loop

' now, for any directories in aDirs call self recursively
If iDir > 0 Then
  For iDir = 1 To UBound(aDirs)
    ListFilesInDirectory aDirs(iDir) & Application.PathSeparator
  Next iDir
End If

End Sub

I would suggest creating a dummy directory with some subdirectories and some typical files in each and testing it first to make sure there is nothing unexpected happening.