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

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

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

    Set Web1 = CreateObject("InternetExplorer.Application")      
    Web1.Visible = True
    Web1.navigate "http://fssprus.ru/iss/ip/"
 
    Do While Not (Web1.ReadyState = 4)
      DoEvents
    Loop
    Set he = Web1.Document.body.all("is[last_name]")
    he.Value = "Пупкин"
    Set he = Web1.Document.body.all("is[first_name]")
    he.Value = "Василий"
 
    Set he = Web1.Document.body.all("is[patronymic]")
    he.Value = "Иванович"
    Set he = Web1.Document.body.all("is[date]")
    he.Value = "01.01.1914"
     
    Set he = Web1.Document.body.all("is[region_id][0]")
    he.Value = "41" 'Камчатка
     
    Set he = Web1.Document.body.all("sub_fiz")
    he.Focus
    he.Click