You could try this...

Option Explicit
Sub testme01()

Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim TempWkbk As Workbook
Dim DestCell As Range
Dim myPWD As String

myPWD = "hi"

'change the folder here
myPath = "C:\my documents\excel\test"
If myPath = "" Then Exit Sub
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.xls")
On Error GoTo 0
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

Set DestCell = Workbooks.Add(1).Worksheets(1).Range("a1")
DestCell.Resize(1, 2).Value _
= Array("Workbook Name", "Ok?")

Application.ScreenUpdating = False

'get the list of files
fCtr = 0
Do While myFile < ""
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
myFile = Dir()
Loop

If fCtr 0 Then
For fCtr = LBound(myNames) To UBound(myNames)
If LCase(myNames(fCtr)) = LCase(ThisWorkbook.Name) Then
'do nothing, skip this file
Else
Application.StatusBar _
= "Processing: " & myNames(fCtr) & " at: " & Now

Set DestCell = DestCell.Offset(1, 0)
DestCell.Value = myNames(fCtr)

Set TempWkbk = Nothing
On Error Resume Next
Set TempWkbk = Workbooks.Open(Filename:=myPath _
& myNames(fCtr), Password:=myPWD)
On Error GoTo 0

If TempWkbk Is Nothing Then
DestCell.Offset(0, 1).Value = "Could not open"
Else
With TempWkbk
.Password = ""
.Save
.Close savechanges:=False
End With
DestCell.Offset(0, 1).Value = "Password removed"
End If
End If
Next fCtr
End If

DestCell.Parent.UsedRange.Columns.AutoFit

With Application
.ScreenUpdating = True
.StatusBar = False
End With

End Sub



Dave Mc wrote:

I have about 500 Excel files which are password protected with the same
password. I do know the password. Is there a utility or can a sciprt be
written to remove all passwords on all files in the same folder ? I am
trying to avoid opening them all and changing the setting manually.

Thanks

--

Dave Peterson