' ************************************************
' копирование данных с листа на лист с преобразованием структуры
' ТЗ: http://www.sql.ru/forum/actualthread.aspx?tid=809349
' используютя объекты ADODB.Connection и ADODB.Recordset
Sub SmartCopy()

Const s_WkSheetFrom$ = "Лист1"      ' лист-источник
Const s_WkSheetTo$ = "Лист2"        ' лист-получатель
Const i_MaxCriteria% =  8             ' кол-во "критериев"
                        ' (!) при большом кол-ве критериев рискуем нарваться
                        ' на ограничение длины текста запроса

Dim oCnn As Object, oRst As Object  ' подключение и наборзаписей (ADO)
Dim sConnStr$                       ' строка соединения
Dim sSQL$                           ' текст запроса
Dim sFrom$                          ' auxiliarry var
Dim i%                              ' counter


' формирование текста запроса
sFrom = " FROM [" & s_WkSheetFrom & "$]"

sSQL = "SELECT [Дата], 'Данные1' as Критерий, [Данные1] as Показатель"
sSQL = sSQL & sFrom

For i =  2  To i_MaxCriteria
    sSQL = sSQL & " UNION ALL"
    sSQL = sSQL & " SELECT [Дата], 'Данные" & i & "', [Данные" & i & "]"
    sSQL = sSQL & sFrom
Next i

' строка подключения к файлу Excel
sConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Mode=Read;Data Source=" _
    & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=2'"

' создание объекта подключение, открытие подключения
Set oCnn = CreateObject("ADODB.Connection")
oCnn.Open sConnStr

' создание объекта наборзаписей как результат выполнения запроса в подключении
Set oRst = oCnn.Execute(sSQL)


With Worksheets(s_WkSheetTo)
    ' формирование заголовков столбцов на листе-получателе
    For i =  0  To oRst.Fields.Count -  1 
        .Cells( 1 , i +  1 ).Value = oRst(i).Name
    Next i
    
    ' копирование данных из наборзаписей на лист-получатель
    .Range("A2").CopyFromRecordset oRst
End With

' закрытие и уничтожение объектов наборзаписей и подключение
oRst.Close: Set oRst = Nothing
oCnn.Close: Set oCnn = Nothing

End Sub