' формирование текста запроса
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

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

'Этот код поместите в ОБЩИЙ модуль:
Public cn As ADODB.Connection
Public rs As ADODB.Recordset
Public pusto As Boolean
Dim errmsg As String
Dim adoerr As ADODB.Error

Public Sub ВыполнитьКоманду(ByVal cnstr As String, ByVal sqlquery As String, ByVal aq As Boolean)
Set cn = CreateObject("ADODB.Connection")
cn.Mode = adModeReadWrite
cn.Open cnstr
        If aq Then
            cn.Execute sqlquery
            cn.Close
            Set cn = Nothing
        Else
            Set rs = CreateObject("ADODB.Recordset")
            rs.CursorType = adOpenStatic
            rs.LockType = adLockBatchOptimistic
            Set rs = cn.Execute(sqlquery)
        End If
End Sub
Public Sub УничтожитьНаборЗаписей(ByVal cntn As Connection, ByVal rst As Recordset)
If Not rst Is Nothing Then
    If rst.State = adStateOpen Then
        rst.Close
    End If
    Set rst = Nothing
End If
If Not cntn Is Nothing Then
    If cntn.State = adStateOpen Then
        cntn.Close
    End If
    Set cntn = Nothing
End If
End Sub
Public Sub ПроверитьНаПустоту(ByVal cntn As Connection, ByVal rst As Recordset)
If rst.BOF = True And rst.EOF = True Then
    rst.Close
    Set rst = Nothing
    cntn.Close
    Set cntn = Nothing
    pusto = True
Else
    pusto = False
End If
End Sub
Public Sub ОбработатьОшибкуЗапроса(ByVal cntn As Connection, ByVal rst As Recordset)
If Not rst Is Nothing Then
    If rst.State = adStateOpen Then
        rst.Close
    End If
Set rst = Nothing
End If
errmsg = ""
If Not cntn Is Nothing Then
    For Each adoerr In cntn.Errors
        errmsg = errmsg & vbCr & "Номер ошибки: " & CStr(adoerr.Number)
        errmsg = errmsg & vbCr & "Описание ошибки: " & adoerr.Description
    Next
    cntn.Errors.Clear
    If cntn.State = adStateOpen Then
        cntn.Close
    End If
    Set cntn = Nothing
End If
If errmsg = "" Then
    errmsg = errmsg & vbCr & "Номер ошибки: " & CStr(Err.Number)
    errmsg = errmsg & vbCr & "Описание ошибки: " & Err.Description
End If
MsgBox errmsg, , "Произошла ошибка"
End Sub
Public Sub ОбработатьОшибкуКоманды(ByVal cntn As Connection)
errmsg = ""
If Not cntn Is Nothing Then
    For Each adoerr In cntn.Errors
        errmsg = errmsg & vbCr & "Номер ошибки: " & CStr(adoerr.Number)
        errmsg = errmsg & vbCr & "Описание ошибки: " & adoerr.Description
    Next
    cntn.Errors.Clear
    If cntn.State = adStateOpen Then
        cntn.Close
    End If
    Set cntn = Nothing
End If
If errmsg = "" Then
    errmsg = errmsg & vbCr & "Номер ошибки: " & CStr(Err.Number)
    errmsg = errmsg & vbCr & "Описание ошибки: " & Err.Description
End If
MsgBox errmsg
End Sub

' Этот код повесьте на кнопку:
On error GoTo errline
Dim cns As String
'cns = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0 Macro;HDR=Yes'"
cns= "Provider=Microsoft.Jet.OLEDB.4.0;Mode=Read;Data Source=" _
    & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=2'"
Set cn = New ADODB.Connection
cn.Mode = adModeReadWrite
cn.Open cns
sqltext = "SELECT [Поле1],[Поле3] FROM [ Лист1$A1:C6]"
ВыполнитьКоманду cns, sqltext, False
set ws=Thisworkbook.Worksheets.Add
ws.name="РезультатЗапроса"
With Worksheets("РезультатЗапроса")
    ' формирование заголовков столбцов на листе-получателе
    For i = 0 To rs.Fields.Count - 1
        .Cells(1, i + 1).Value = rs.Fields(i).Name
    Next i    
    ' копирование данных из набора записей на лист-получатель
    .Cells(2,1).CopyFromRecordset rs
End With
УничтожитьНаборЗаписей cn, rs
Exit Sub

errline:
ОбработатьОшибкуЗапроса cn, rs
End Sub

' Этот код повесьте на кнопку:
On error GoTo errline
Dim cns As String
'cns = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0 Macro;HDR=Yes'"
cns= "Provider=Microsoft.Jet.OLEDB.4.0;Mode=Read;Data Source=" _
& ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=2'"
sqltext = "SELECT [Поле1],[Поле3] FROM [ Лист1$A1:C6]"
ВыполнитьКоманду cns, sqltext, False
set ws=Thisworkbook.Worksheets.Add
ws.name="РезультатЗапроса"
With Worksheets("РезультатЗапроса")
' формирование заголовков столбцов на листе-получателе
For i = 0 To rs.Fields.Count - 1
.Cells(1, i + 1).Value = rs.Fields(i).Name
Next i 
' копирование данных из набора записей на лист-получатель
.Cells(2,1).CopyFromRecordset rs
End With
УничтожитьНаборЗаписей cn, rs
Exit Sub

errline:
ОбработатьОшибкуЗапроса cn, rs
End Sub