Dim calcSheet As Worksheet
    set calcSheet=activeworkbook.Sheets.Add(Type:="c:\path\template1.xlsx")

Public Function getOrder(ByVal sentence) As Long
    Dim pReg As Object, textNum As String
    Set pReg = CreateObject("VBScript.RegExp")
    pReg.Pattern = "(?:one|two|три|four)$"
    textNum = pReg.Execute(sentence)(0).Value
    getOrder = Switch(textNum = "one", 1, textNum = "two", 2, textNum = "три", 3, textNum = "four", 4)
End Function

Worksheets(2).Range("A1:B2").Value(xlRangeValueXMLSpreadsheet) = Worksheets(1).Range("A1:B2").Value(xlRangeValueXMLSpreadsheet)

Public Sub createProcutConnectionConntection()
    Const baseConn As String = "ODBC;DBQ=$1;Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DriverId=1046;MaxBufferSize=2048;PageTimeout=5;ReadOnly=1;"
    Const baseSQL = "Select '$1' As [Товар], [Фирма], [Название], [Масса] From [$1$]"
    Dim sConn As String, sSQL As String, i As Long, arrList As Variant
    Dim lCol As ListColumn
    sConn = Replace$(baseConn, "$1", ThisWorkbook.FullName)
    Set lCol = ThisWorkbook.Worksheets("Список").ListObjects(1).ListColumns(1)
    arrList = lCol.DataBodyRange.Value
    sSQL = ""
    For i = 1 To UBound(arrList, 1)
        If sSQL = "" Then
            sSQL = Replace$(baseSQL, "$1", arrList(i, 1))
        Else
            sSQL = sSQL & " Union All " & Replace$(baseSQL, "$1", arrList(i, 1))
        End If
    Next
    ThisWorkbook.Connections.Add _
        "Товары_" & Format$(Now, "yyyymmdd_hhnnss"), _
        "Подключение для сводной по товарам", _
        sConn, _
        sSQL, _
        xlCmdSql
End Sub