Sub Del_Wsch() 'Удаляет лишние листы в книке счетов
Dim iWb As Workbook
Dim iSh As Worksheet
Dim wsStart&, I&
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook
  'открываю книгу со счетами из текущей папки, название книги в ячейке 'B1' листа 'Счета'
  Set iWb = Workbooks.Open(.Path & "\" & .Worksheets("Счета").Range("B1").Text)
End With
If Not iWb Is Nothing Then
  wsStart = iWb.Worksheets("ТН").Index + 1
  For I = iWb.Worksheets.Count To wsStart Step -1
    iWb.Worksheets(I).Delete
  Next
End If
iWb.Close True
Application.ScreenUpdating = True
MsgBox "Done!"
Exit Sub
ErrHandler:
    MsgBox "При выполнении макроса возникла ошибка!", vbCritical
End Sub

Sub Del_Wsch() 'Удаляет лишние листы в книке счетов
Dim iWb As Workbook
Dim iSh As Worksheet
Dim wsStart&, I&
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook
  'открываю книгу со счетами из текущей папки, название книги в ячейке 'B1' листа 'Счета'
  Set iWb = Workbooks.Open(.Path & "\" & .Worksheets("Счета").Range("B1").Text)
End With
If Not iWb Is Nothing Then
  wsStart = iWb.Worksheets("ТН").Index + 1
  For I = wsStart To iWb.Worksheets.Count
    iWb.Worksheets(I).Delete
  Next
End If
iWb.Close True
Application.ScreenUpdating = True
MsgBox "Done!"
Exit Sub
ErrHandler:
    MsgBox "При выполнении макроса возникла ошибка!", vbCritical
End Sub

Sub clean_sch() 'Удаляет лишние листы в книке счетов
Dim iWb As Workbook
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook
  'открываю книгу со счетами из текущей папки, название книги в ячейке 'B1' листа 'Счета'
  Set iWb = Workbooks.Open(.Path & "\" & .Worksheets("Счета").Range("B1").Text)
End With
Application.Run Macro:=iWb.Name & "!ModDeliter.Delet_sch"
iWb.Close True
Application.ScreenUpdating = True
MsgBox "Done!"
Exit Sub
ErrHandler:
    MsgBox "При выполнении макроса возникла ошибка!", vbCritical
End Sub

Sub Delet_sch()
  Dim bo As Boolean
  Application.DisplayAlerts = False 'отключаю запрос на удаление
  bo = True
  Do While bo 'делаю пока = true
    With ThisWorkbook
      If .Sheets(.Sheets.Count).Name = "ТН" Then bo = False
      If bo Then .Sheets(.Sheets.Count).Delete
    End With
  Loop
  Application.DisplayAlerts = True
End Sub

Sub clean_sch() 'Удаляет лишние листы в книке счетов
Dim iWb As Workbook
Dim iSh As Worksheet
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook
  'открываю книгу со счетами из текущей папки, название книги в ячейке 'B1' листа 'Счета'
  Set iWb = Workbooks.Open(.Path & "\" & .Worksheets("Счета").Range("B1").Text)
End With
If Not iWb Is Nothing Then
  For Each iSh In iWb.Worksheets
    If iSh.Name <> "ТН" Then iSh.Delete
  Next
End If
iWb.Close True
Application.ScreenUpdating = True
MsgBox "Done!"
Exit Sub
ErrHandler:
    MsgBox "При выполнении макроса возникла ошибка!", vbCritical
End Sub

Function МНЦП(текст, таблица As Range) As String
Dim tblArr()
Dim dic1 As Object, dic2 As Object
Dim iKey, iKey1, iTmp, iTmp1
Dim I&
On Error Resume Next
tblArr = таблица.Value
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
For I = LBound(tblArr, 1) To UBound(tblArr, 1)
  If tblArr(I, 1) Like "город*" Then
    dic1(tblArr(I, 2)) = tblArr(I, 1)
  Else
    dic2(tblArr(I, 2)) = tblArr(I, 1)
  End If
Next
iTmp = Split(Application.Trim(текст), ",")
For Each iKey In iTmp
  iTmp1 = Split(Application.Trim(iKey), " ")
  For Each iKey1 In iTmp1
    If dic1.Exists(iKey1) Then
      МНЦП = dic1(iKey1)
      Exit Function
    ElseIf dic2.Exists(iKey1) Then
      МНЦП = dic2(iKey1)
    End If
  Next
Next
If МНЦП = "" Then МНЦП = "Нет данных"
End Function