Sub GetSheet()
'процедура запуска кнопки Загрузка на лист
'объявляем переменные
Dim R As Range, i&, j&, Clr&, Clr1&, cnt&, cnt1&, Lr&, EH
'Dim Dict As Object
cnt = 1
cnt1 = 1
With Sheets("БД(ТЭП)") ' на листе БД(ТЭП)
Clr = .Range("F4").Interior.ColorIndex ' запоминаем цветовой диапазон
'Clr1 = .Range("F3").Interior.ColorIndex ' устанавливаем цветовой диапазон
Lr = .Cells(.Rows.Count, "A").End(xlUp).Row 'номер последней заполненной ячейки в столбце А
.Range("a1").Resize(Lr, 2).ClearContents 'удаляем содержимое из столбцов А:В до последней заполненной ячейки в столбце А

Windows("ТЭП15авт.xls").Activate 'Активируем книгу "ТЭП15авт.xls"
'на листе с именем из Range("F6") листа "БД(ТЭП)" диапазон из F5 запоминаем в переменную R
Set R = Sheets(.Range("F6").Value).Range(.Range("F5").Value)
            'выводим название столбцов (на лист БД(ТЭП))
            .Cells(1, 1).Value = "Показатель"   'выводим название столбца "Показатель"
            .Cells(1, 2).Value = "Значение"   'выводим название столбца "Значение"
            .Cells(1, 8).Value = "Показатель" 'выводим название столбца "Показатель"
            .Cells(1, 9).Value = "Значение"   'выводим название столбца "Значение"
                    
For i = 1 To R.Rows.Count 'по строкам диапазона R
            For j = 1 To R.Columns.Count 'по столбцам диапазона R
            If R(i, j).Interior.ColorIndex = Clr Then ' Если ячейка имеет цвет Clr
            cnt = cnt + 1 ' Прибавляем счетчик
            .Cells(cnt, 1).Value = R(i, j).Name.Name 'имя ячейки(в смысле имя диапазона из ctrl+f3)
            .Cells(cnt, 2).Value = R(i, j).Value 'значение ячейки
        End If
            Next
Next

Clr1 = .Range("F20, F3").Interior.ColorIndex ' запоминаем цветовой диапазон
For i = 1 To R.Rows.Count 'по строкам диапазона R
            For j = 1 To R.Columns.Count 'по столбцам диапазона R
            If R(i, j).Interior.ColorIndex = Clr1 Then ' Если ячейка имеет цвет Clr1
            cnt1 = cnt1 + 1 ' Прибавляем счетчик
            .Cells(cnt1, 8).Value = R(i, j).Name.Name 'имя ячейки(в смысле имя диапазона из ctrl+f3)
            .Cells(cnt1, 9).Value = R(i, j).Value 'значение ячейки
            End If
            Next
Next
End With
End Sub

Sub LoadSheet()
'процедура запуска кнопки Заполнение макета данными
'объявление переменных
Dim a, Lr&
With Sheets("БД(ТЭП)") ' на листе БД(ТЭП)
Lr = .Cells(.Rows.Count, "A").End(xlUp).Row 'номер последней заполненной ячейки в столбце А
'запоминаем в "а" содержимое из столбцов А:В до последней заполненной ячейки в столбце А
a = .Range("a1").Resize(Lr, 2).Value
For i = 2 To UBound(a) 'От 2 до верхней границы а (по строкам)

Windows("ТЭП15авт.xls").Activate 'Активируем книгу "ТЭП15авт.xls"

Range(a(i, 1)).Value = a(i, 2) 'пишем значение из а 2-го столбца
Next
End With
MsgBox "Данные заполнены" 'отображение результата
End Sub

'-------------------------------------------
' процедура запуска кнопки Загрузка на лист
'-------------------------------------------
Sub GetSheet()
       'объявляем переменные
       Dim R As Range, i&, j&, Clr&, cnt&, Lr&, EH
       'Dim Dict As Object
          
       With Sheets("БД(ТЭП)") ' на листе БД(ТЭП)
           Clr = .Range("F4").Interior.ColorIndex      ' сохраняем цвет ячейки F4 в переменную Clr
           'Clr1 = .Range("F3").Interior.ColorIndex    ' сохраняем цвет ячейки F3 в переменную Clr1
           Lr = .Cells(.Rows.Count, 1).End(xlUp).Row   ' сохраняем в переменную Lr номер последней заполненной строки (проверяя по столбцу "A")
           .Range("A1:B" & Lr).ClearContents           ' удаляем содержимое ячеек в диапазоне "A1:Bxxx" (где xxx - номер последней заполненной строки, полученный в пред. строке кода)
              
           Windows("ТЭП15авт.xls").Activate            ' делаем активным документ "ТЭП15авт.xls"
              
           Set R = Sheets(.Range("F6").Value).Range(.Range("F5").Value) ' переменной R присваиваем ссылку на диапазон, указанный в ячейке F5 и расположенный на листе, указанном в ячейке F6
           ' выводим названия столбцов A, B, H, I
           .Cells(1, 1).Value = "Показатель"   ' записываем в ячейку A1 - "Показатель"
           .Cells(1, 2).Value = "Значение"     ' записываем в ячейку B1 - "Значение"
           .Cells(1, 8).Value = "Показатель"   ' записываем в ячейку H1 - "Показатель"
           .Cells(1, 9).Value = "Значение"     ' записываем в ячейку I1 - "Значение"
              
           cnt = 2 ' номер первой (для заполнения) строки таблицы   (т.к. 1-я строка на листе - это шапка таблицы, т.е., заголовки столбцов)
           ' проходим в цикле по всем ячейка диапазона, присвоенного переменной R (см. выше)
           For i = 1 To R.Rows.Count ' !!! здесь логичнее начинать сразу со 2-строки, а не с 1-й, т.к. в первой строке находится шапка таблицы
               For j = 1 To R.Columns.Count
                   If R(i, j).Interior.ColorIndex = Clr Then    ' если цвет ячейки совпадает с цветом ячейки F4 на листе "БД(ТЭП)"
                       .Cells(cnt, 1).Value = R(i, j).Name.Name ' то копируем Показатель
                       .Cells(cnt, 2).Value = R(i, j).Value     ' и Значение из диапазона R (см. выше)
                       cnt = cnt + 1   ' это будет номер следующей (для заполнения) строки таблицы
                   End If
               Next
           Next
              
' !!! см комментарии пред. цикла (и, скорее всего, эти 2 цикла можно и нужно объединить в один и не тратить вдвое больше времени на обработку, как сейчас)(но нужно знать задачу)
           cnt = 2
           Clr = .Range("F20, F3").Interior.ColorIndex
           For i = 1 To R.Rows.Count
               For j = 1 To R.Columns.Count
                   If R(i, j).Interior.ColorIndex = Clr Then
                       .Cells(cnt, 8).Value = R(i, j).Name.Name
                       .Cells(cnt, 9).Value = R(i, j).Value
                       cnt = cnt + 1
                   End If
               Next
           Next
       End With
End Sub

'--------------------------------------
' экспортируем (сохраняем) записи в БД
'--------------------------------------
Sub ExportAccess() ' процедура работы кнопки Экспорта
     Dim cn_ As Object, rs As Object, sCon$, FilePath$, Dt As Date, sSql$, Lr&, a, i&
      
     With Sheets("БД(ТЭП)") ' выбор перемнных с листа "БД(ТЭП)" и опредление пути к файлу
         FilePath = .Range("F7").Value               ' см. выше
         Dt = .Range("F8").Value                     ' см. выше
         Lr = .Cells(.Rows.Count, "A").End(xlUp).Row ' см. выше
          
         ' составляем строку запроса
         sSql = "select * from data where controldate=#" & Format(Dt, "mm\/dd\/yy hh\:mm\:ss") & "#"
          
         ' указываем параметры соединения с БД
         sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
         sCon = sCon & FilePath & ";User Id=admin;Password=;" 'Access
          
         ' устанавливаем соединение с БД
         Set cn_ = CreateObject("ADODB.Connection") 'создаем данные
         cn_.Open sCon
          
         ' если соединение с БД не установлено - выходим из процедуры экспорта
         If Not cn_.State = 1 Then Exit Sub
          
         ' если соединение с БД установлено - получаем набор записей по запросу sSql
         Set rs = GetRs(cn_, sSql)
          
         ' если в БД уже есть записи - спрашиваем о их замене
         If rs.RecordCount Then
             If MsgBox(" Данные за эту дату уже есть в базе, заменить?", vbQuestion Or vbYesNo) <> vbYes Then _
                 Exit Sub ' если пользователь ответил "Нет" - выходим из процедуры экспорта
              
             ' удаляем из БД старые записи за указанную дату
             cn_.Execute ("delete * from data where controldate=#" & Format(Dt, "mm\/dd\/yy hh\:mm\:ss") & "#")
         End If
          
         ' записываем в БД новые записи с указанной датой из таблицы Excel
         a = .Range("a1").Resize(Lr, 2).Value
         With rs
             .Requery
             For i = 2 To UBound(a)
                 .addnew                    ' добавляем новую запись
                 .Fields("controldate").Value = Dt       ' заполняем поля
                 .Fields("controlName").Value = a(i, 1)
                 .Fields("controlValue").Value = a(i, 2)
                 .Update                    ' сохраняем запись
             Next
         End With
     End With
End Sub

'--------------------------------------------
' импортируем (получаем) набор записей из БД
'--------------------------------------------
Sub ImportAccess()
           Dim cn_ As Object, rs As Object, sCon$, FilePath$, Dt As Date, sSql$, Lr&
                  
           With Sheets("БД(ТЭП)")                          ' см. выше
               FilePath = .Range("F7").Value               ' см. выше
               Dt = .Range("F8").Value                     ' см. выше
               Lr = .Cells(.Rows.Count, "A").End(xlUp).Row ' см. выше
               .Range("a1").Resize(Lr, 2).ClearContents    ' см. выше
                      
               ' составляем строку запроса
               sSql = "select controlName, controlValue from data where controldate=#" & Format(Dt, "mm\/dd\/yy hh\:mm\:ss") & "#"
                      
               ' указываем параметры соединения с БД
               sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
               sCon = sCon & FilePath & ";User Id=admin;Password=;" 'Access
                      
               ' устанавливаем соединение с БД
               Set cn_ = CreateObject("ADODB.Connection") 'создаем данные
               cn_.Open sCon
                      
               ' если соединение с БД не установлено - выходим из процедуры импорта
               If Not cn_.State = 1 Then Exit Sub
                      
               ' если соединение с БД установлено - получаем набор записей по запросу sSql
               Set rs = GetRs(cn_, sSql)
                      
               If rs.RecordCount > 0 Then
                   ' записываем все записи, которые вернул запрос, на лист Excel
                   .Cells(1, 1).Value = "Показатель"
                   .Cells(1, 2).Value = "Значение"
                   .Range("a2").CopyFromRecordset rs 'помещаем данные в excel
               Else
                   ' запрос не вернул ни одной записи
                   MsgBox " Данных нет...."
               End If
           End With
End Sub

'-------------------------------------
' Возвращает набор записей по запросу
'-------------------------------------
Function GetRs(cn_ As String, sSql As String) As Object
           Set rstdata = CreateObject("ADODB.Recordset") ' создаем новый объект Recordset (набор записей)
           With rstdata ' работаем с методами и свойствами этого объекта
'        .CursorType = adOpenForwardOnly
'        .CursorLocation = adUseClient
'        .LockType = adLockReadOnly
               .Open sSql, cn_, 3, 3 ' получаем статический набор данных по запросу sSql, с параметрами соединения cn_
           End With
           Set GetRs = rstdata     ' возвращаем полученный набор записей в вызвавшую процедуру (ExportAccess или ImportAccess)
           Set rstdata = Nothing   ' освобождаем память, занимаемую этим объектом
End Function