Private WithEvents App As Application
Private Sub Workbook_Open()
    Set App = Application
End Sub
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
    ' Если открыт телефонный справочник, открыть страницу КЭ, развернуть группировку
    If Wb.Name = "Тел - справ.xls" Then
        Wb.Sheets("КЭ").Select
        'ActiveSheet.Outline.ShowLevels RowLevels:=3
    End If
End Sub

Private WithEvents App As Application
Private Sub Workbook_Open()
    Set App = Application
End Sub
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
    ' Если открыт телефонный справочник, открыть страницу КЭ, развернуть группировку
    If Wb.Name = "Тел - справ.xls" Then
        Sheets("КЭ").Select
        ActiveSheet.Outline.ShowLevels RowLevels:=3
    End If
End Sub

?Private Sub Workbook_Open()
    ' Если открыт телефонный справочник, открыть страницу КЭ, развернуть группировку
    If ActiveWorkbook.Name = Тел - справ.xls Then
            Sheets("КЭ").Select
            ActiveSheet.Outline.ShowLevels RowLevels:=3
    End If
End Sub

.Rows(iRow_Sd & ":" & iRow_Sd + 100 - 1).Insert Shift:=xlDown

       iRow_Sd = 6        'по всем записям в реестре
        For iRow_Rr = 6 To 500
            'по выбранному табельному
            If wsh_Реестр.Cells(iRow_Rr, 1) Like Табельный Then
                'добавить строку
                .Rows(iRow_Sd).Copy
                .Rows(iRow_Sd).Insert Shift:=xlDown
                Application.CutCopyMode = False ' ОЧИСТИТЬ БУФЕР ОБМЕНА
                DoEvents
                Application.StatusBar = "Добавлена строка из реестра: " & iRow_Sd
                For iColumn = 1 To 100
                    If wsh_Реестр.Cells(1, iColumn) <> "" Then
                        .Cells(iRow_Sd, Столбец(wsh_Реестр.Cells(1, iColumn), wsh_Свод.Name)) = _
                        wsh_Реестр.Cells(iRow_Rr, iColumn)
                    End If
                Next
                iRow_Sd = iRow_Sd + 1
            End If
        
        Next

iRow_Sd = iRow_Sd + 1

For iRow_Rr = 6 To 500 

iRow_Sd = iRow_Sd + 1

                 .Rows(iRow_Sd).Copy
                .Rows(iRow_Sd).Insert Shift:=xlDown
                Application.CutCopyMode = False 
                DoEvents
                Application.StatusBar = "Добавлена строка: " & iRow_Sd

 'очищаем лист свод
        Call ОчиститьСвод
        iRow_Sd = 6
        'по всем записям в реестре
        For iRow_Rr = 6 To 500
            'по выбранному табельному
            If wsh_Реестр.Cells(iRow_Rr, 1) Like Табельный Then
                'добавить строку
                .Rows(iRow_Sd).Copy
                .Rows(iRow_Sd).Insert Shift:=xlDown
                Application.CutCopyMode = False ' ОЧИСТИТЬ БУФЕР ОБМЕНА
                DoEvents
                Application.StatusBar = "Добавлена строка из реестра: " & iRow_Sd
                For iColumn = 1 To 100
                    If wsh_Реестр.Cells(1, iColumn) <> "" Then
                        .Cells(iRow_Sd, Столбец(wsh_Реестр.Cells(1, iColumn), wsh_Свод.Name)) = _
                        wsh_Реестр.Cells(iRow_Rr, iColumn)
                    End If
                Next
                iRow_Sd = iRow_Sd + 1
            End If
       
        Next

    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False

                .Rows(iRow_Sd).Copy
                .Rows(iRow_Sd).Insert Shift:=xlDown
                Application.CutCopyMode = False
                Application.StatusBar = "Добавлена строка: " & iRow_Sd

Public Function ЧастьКода(Строка As String, Разделитель As String, Часть As Integer)
    Dim Массив() As String
    Массив = Split(Строка, Разделитель)
    ЧастьКода = Массив(Часть - 1)
End Function

Public Sub Получить6()
    Dim Адрес6 As String
    Dim i As String
    Dim Прграмма As Workbook
    Dim Прил6 As Workbook
    Dim ИмяФайла As String
    On Error GoTo lable_1
    Application.ScreenUpdating = False    ' Отключаем “мерцание” окна
    Set Прграмма = ThisWorkbook
    Адрес6 = Прграмма.Worksheets("Const").Cells(1, 2) 'здесь должна быть маска K:\Отчеты 1,2,3,4 кв\*.xls*
    'Workbooks.Open Filename:=Адрес6, UpdateLinks:=0, Notify:=False
    ИмяФайла = Dir(Адрес6)
    Do While ИмяФайла <> ""
        If ИмяФайла Like "*xls*" Then
            Адрес6 = Адрес6 & ИмяФайла
            Exit Do
        End If
        ИмяФайла = Dir
    Loop
    Workbooks.Open Filename:=Адрес6, ReadOnly:=True, UpdateLinks:=0
    Set Прил6 = ActiveWorkbook
    Прил6.Sheets("филиал 1").Copy After:=Прграмма.Worksheets(Прграмма.Worksheets.Count)
    Прграмма.Sheets("Ожидаемые").Activate
    Прил6.Close (False)
    Application.ScreenUpdating = True ' Возвращаем режим обновления экрана при изменении
    Exit Sub
    
    MsgBox "Нет связи с базой данных," & Chr(13) _
    & "возможно файл перемещен," & Chr(13) _
    & "обратитесь к Андрею ))!!!", vbOKOnly + vbCritical
End Sub

Workbooks.Open Filename:= "C:\...", ReadOnly:=True

Function IsBookOpen(wbFullName As String) As Boolean
    Dim iFF As Integer
    iFF = FreeFile
    On Error Resume Next
    Open wbFullName For Random Access Read Write Lock Read Write As #iFF
    Close #iFF
    IsBookOpen = Err
End Function

Public Sub Получить6()
    Dim Адрес6 As String
    Dim Прграмма As Workbook
    Dim Прил6 As Workbook
    'On Error GoTo lable_1
    Application.ScreenUpdating = False    ' Отключаем “мерцание” окна
    Set Прграмма = ThisWorkbook
    Адрес6 = K:\Отчеты 1,2,3,4 кв\*.xls*"
    If IsBookOpen(Адрес6) Then
        Set Прил6 = Workbooks(Адрес6)
        'Open Workbooks(Адрес6) For Input As #1
        Else: Set Прил6 = Workbooks.Open(Адрес6)
    End If
    Application.DisplayAlerts = False
    Прил6.Sheets("филиал 1").Copy After:=Прграмма.Worksheets(Прграмма.Worksheets.Count)
    Application.DisplayAlerts = True
    Прграмма.Sheets("Ожидаемые").Activate
    Прил6.Close (False)
    Application.ScreenUpdating = True ' Возвращаем режим обновления экрана при изменении
    Exit Sub
    
    MsgBox "Нет связи с базой данных," & Chr(13) _
    & "возможно файл перемещен," & Chr(13) _
    & "обратитесь к Андрею ))!!!", vbOKOnly + vbCritical
End Sub

Public Sub Получить6()
    Dim Адрес6 As String
    Dim Прграмма As Workbook
    Dim Прил6 As Workbook
    'On Error GoTo lable_1
    Application.ScreenUpdating = False    ' Отключаем “мерцание” окна
    Set Прграмма = ThisWorkbook
    Адрес6 = Прграмма.Worksheets("Const").Cells(1, 2) 'здесь должна быть маска K:\Отчеты 1,2,3,4 кв\*.xls*
    Workbooks.Open Filename:=Адрес6, UpdateLinks:=0, Notify:=False
    Set Прил6 = ActiveWorkbook
    Прил6.Sheets("филиал 1").Copy After:=Прграмма.Worksheets(Прграмма.Worksheets.Count)
    Прграмма.Sheets("Ожидаемые").Activate
    Прил6.Close (False)
    Application.ScreenUpdating = True ' Возвращаем режим обновления экрана при изменении
    Exit Sub
    
    MsgBox "Нет связи с базой данных," & Chr(13) _
    & "возможно файл перемещен," & Chr(13) _
    & "обратитесь к Андрею ))!!!", vbOKOnly + vbCritical
End Sub

Sub РасшифороватьКод()
    Dim Лесхоз As String
    Dim Лесничство As String
    Dim Квартал As String
    Dim Выдел As String
    Dim Делянка As String
    Dim ДлиннаСтроки As Integer
    Dim Код As String
    
    Код = "12-41-102-2-55" 'может содержать строковые, маска "*-*-*-*-*"
    ДлиннаСтроки = Len(Код)
    Лесхоз = Left(Код, InStr(Код, "-") - 1)
    Код = Right(Код, ДлиннаСтроки - InStr(Код, "-"))
    ДлиннаСтроки = Len(Код)
    Лесничство = Left(Код, InStr(Код, "-") - 1)
    Код = Right(Код, ДлиннаСтроки - InStr(Код, "-"))
    ДлиннаСтроки = Len(Код)
    Квартал = Left(Код, InStr(Код, "-") - 1)
    Код = Right(Код, ДлиннаСтроки - InStr(Код, "-"))
    ДлиннаСтроки = Len(Код)
    Выдел = Left(Код, InStr(Код, "-") - 1)
    Код = Right(Код, ДлиннаСтроки - InStr(Код, "-"))
    Делянка = Код
End Sub