Option Explicit
Const sPath As String = "C:\Users\Z\Desktop\testt\"
Const sFind As String = "email@find.com"
Const sRepl As String = "email@replace.com"
Sub CopySameSheetFrmWbs()
Dim wbOpen As Workbook, ws As Worksheet
Dim sExt As String, bWbOpen As Boolean, sName As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir sPath
sExt = Dir("*.xls")
Do While sExt <> ""
sName = Right(sPath & sExt, Len(sPath & sExt) - InStrRev(sPath & sExt, "\"))
Set wbOpen = Workbooks(sName)
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