Sub CopySameSheetFrmWbs()
Dim wbOpen As Workbook, ws As Worksheet
Dim sExt As String, bWbOpen As Boolean, sName As String
Application.EnableEvents = True ' False
Application.ScreenUpdating = True ' False
Application.Calculation = xlCalculationAutomatic ' xlCalculationManual
' On Error Resume Next
ChDir sPath
sExt = Dir("*.xls")
Do While sExt <> ""
sName = Right(sPath & sExt, Len(sPath & sExt) - InStrRev(sPath & sExt, "\"))
On Error Resume Next
Set wbOpen = Workbooks(sName)
On Error GoTo 0
bWbOpen = True
If wbOpen Is Nothing Then
Set wbOpen = Workbooks.Open(sPath & sExt)
bWbOpen = False
End If
For Each ws In wbOpen.Worksheets
ws.Cells.Replace sFind, sRepl
Next ws
If bWbOpen = False Then
wbOpen.Close SaveChanges:=True
Else
If wbOpen.Saved = False Then wbOpen.Save
End If
Set wbOpen = Nothing
sExt = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub