Sub root()

tm = 10 'Количество заменяемых значений

Dim Zam_W: ReDim Zam_W(tm) 'Массив для храниея "ЧТО
заменяем"

Dim
Zam_T: ReDim Zam_T(tm) 'Массив для храниея "Чем заменяем"

Zam_W(1)
= "Тюменьэнерго" 

Zam_T(1)
= "Россети Тюмень" 

Zam_W(2)
= "ОКС УИиКС ТРС" 

Zam_T(2)
= "ОКС УИиКС" 

Zam_W(3)
= "Тюменские распределительные сети"

 Zam_T(3) = "Тюменские электрические
сети" 

For i = 1 To tm

If Zam_W(i) <> 0 Then Call
Zamena(Zam_W(i), Zam_T(i))

Next i

End Sub

Function Zamena(z_21, z_22)

Cells.Replace What:=z_21, replacement:=z_22,
MatchCase:=True

End Function

Sub Сбор_листов_в_один_файл()
 Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов
 Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат
 Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
 i As Integer, stbar As Boolean
 On Error Resume Next 'если указанный путь не существует, обзор начнется с пути по умолчанию
 ChDir strStartDir
 On Error GoTo 0
 With Application 'меньше писанины
 arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
 If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
 Set wbTarget = Workbooks.Add(template:=xlWorksheet)
 .ScreenUpdating = False
 stbar = .DisplayStatusBar
 .DisplayStatusBar = True
 .DisplayAlerts = False
 For i = 1 To UBound(arFiles)
 .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
 Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
 For Each shSrc In wbSrc.Worksheets
 If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
 Set shTarget = wbTarget.Sheets.Add(after:=wbTarget.Sheets(wbTarget.Sheets.Count))
 shTarget.Name = shSrc.Name & "-" & i
 shSrc.Cells.Copy shTarget.Range("A1")
 End If
 Next
 wbSrc.Close False 'закрыть без запроса на сохранение
 Next
 .ScreenUpdating = True
 .DisplayStatusBar = stbar
 .StatusBar = False
 If wbTarget.Sheets.Count = 1 Then 'не добавлено ни одного листа
 MsgBox "В указанных книгах нет непустых листов, сохранять нечего!"
 wbTarget.Close False
 End
 Else
 .DisplayAlerts = False
 wbTarget.Sheets(1).Delete
 .DisplayAlerts = True
 End If
 On Error Resume Next 'если указанный путь не существует и его не удается создать,
 'обзор начнется с последней использованной папки
 If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
 ChDir strSaveDir
 On Error GoTo 0
 arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")
 If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
 GoTo save_err
 Else
 On Error GoTo save_err
 wbTarget.SaveAs arFiles
 End If
 End
 save_err:
 MsgBox "Книга не сохранена!", vbCritical
 End With
 End Sub

Private Sub Workbook_Open()
Dim i&, n&, P As Variant
Application.ScreenUpdating = False
n = 2
If Date = "05.05.2014" Then
For i = 1 To Sheets.Count
    Sheets(i).Activate
    Sheets(i).Protect "1234"
Next
End If
1:
P = InputBox("Время использования книги истекло, для продолжения введите пароль", "ВВОД ПАРОЛЯ")
If P = 1234 Then
For i = 1 To Sheets.Count
    Sheets(i).Activate
    Sheets(i).Unprotect "1234"
Next
Else
  If n = 0 Then
  Application.DisplayAlerts = False
  ThisWorkbook.Close
  Application.DisplayAlerts = True
  Else
  MsgBox "Пароль не верный, у вас еще " & n & " попытки"
  n = n - 1
  End If
  GoTo 1
End If
Application.ScreenUpdating = True
End Sub