Public Function TrasferExcel() 'Функция передачи данных в Эксель
Dim oExcel As Object, oBook As Object, oSheet As Object, sqlstr As String, db As DAO.Database, fso As New FileSystemObject, fil
  
'Проверяем наличие папки C:\MATHERIALS Если нету - создаем
  If ExistDir("C:\MATHERIALS") = False Then
  fso.CreateFolder ("C:\MATHERIALS")
  End If
  
   
  Me.ProgressBar1.Value =  85 
  
  sqlstr = "SELECT 0 AS FOLDER_ID, MATHERIALS.REFERENCE, IIf(MATHERIALS.UNIT='м',(((Fix((Round(Sum(MATHERIALS.[Sum-STKOUT_QTY]),2))/6))+1)*6),(Round(Sum(MATHERIALS.[Sum-STKOUT_QTY]),2))) AS [Sum-Sum-STKOUT_QTY], MATHERIALS.DESCRIPTION, MATHERIALS.UNIT, Z.[Sum-QTY], X.[Sum-SM2] " & _
"FROM MATHERIALS, (SELECT Sum(Z2.QTY) AS [Sum-QTY] FROM (SELECT MATHERIALS.QTY FROM MATHERIALS GROUP BY MATHERIALS.QTY, MATHERIALS.FOLDER_ID) AS Z2) AS Z, (SELECT Sum(X2.SM2) AS [Sum-SM2] FROM (SELECT MATHERIALS.SM2 FROM MATHERIALS GROUP BY MATHERIALS.SM2, MATHERIALS.FOLDER_ID) AS X2) AS X " & _
"GROUP BY 0, MATHERIALS.REFERENCE, MATHERIALS.DESCRIPTION, MATHERIALS.UNIT, Z.[Sum-QTY], X.[Sum-SM2] " & _
"ORDER BY MATHERIALS.DESCRIPTION;"

  
   Set db = DAO.OpenDatabase(App.Path & "\at.mdb")
   Set Me.Data1.Recordset = db.OpenRecordset(sqlstr)
   
   
   Set oExcel = CreateObject("Excel.Application")
   Set oBook = oExcel.Workbooks.Add
   Set oSheet = oBook.Worksheets("Лист1")
   oExcel.Visible = False
    If Me.Data1.Recordset.RecordCount <  1  Then
    MsgBox "Данных, за указанный период, удовлетворяющим заданным условиям найдено не было." & vbCrLf & "Экспорт в EXCEL  невозможен",  48 , "ВОЗВРАЩЕН ПУСТОЙ НАБОР ДАННЫХ"
    oExcel.Application.Cells.Select
    oExcel.Application.Range("A1").Activate
    oExcel.Application.Selection.ClearContents
    oExcel.Application.Range("A2").Select
    oBook.Save
    oExcel.Quit
    Set oExcel = Nothing
    vOsh = True
Exit Function