Private Sub Кнопка3_Click()
    Dim nRows As Long
    Dim myOlApp As Excel.Application
    Dim MyWo As Excel.Workbook
    Dim mysheet As Excel.Worksheet
    Dim MyCel As Variant
    Dim MyRst As ADODB.Recordset
    Dim MyRst2 As ADODB.Recordset
    Dim strcon As ADODB.Connection
    Dim strconnect As String
    Dim strN As String
    Dim strST As String
    Dim strOS As String
    Dim strSum As String
    Dim ct As Long
    Dim m As Long
    Dim strSql As String
DoCmd.OutputTo acOutputTable, "svod", acFormatXLS, mysave_file, False
Set myOlApp = New Excel.Application
Set MyWo = myOlApp.Workbooks.Open("c:\test.xls")
Set mysheet = MyWo.Worksheets("svod")
'+++++++++++++++++++++++ Определение количества столбцов++++++++++++++++++++++++++++++++++++
m = MyWo.Worksheets(1).Range("A1").CurrentRegion.Columns.Count

myOlApp.Selection.Rows.AutoFit
'+++++++++++++++++++Подключение++++++++++++++++++++++++++++++++++++++++
    Set strcon = CurrentProject.Connection
'-------------------------------------------------------------
    Set MyRst = New ADODB.Recordset
    MyRst.Open "select * from balance", strcon, adOpenStatic, adLockReadOnly

'++++++++++++Подсчёт суммарной стоимости по строкам и столбцам от первой до последней+++++++++++++++++++++++
    nRows = mysheet.Range("A1").CurrentRegion.Rows.Count
    mysheet.Range("a" & (nRows +  1 )).Value = "Итого"
    Set MyRst2 = New ADODB.Recordset
    MyRst2.Open "select * from svod", strcon, adOpenStatic, adLockReadOnly
'-------------------------Серый фон + Окантовка -------------------------------------------------
   mysheet.Range(Chr(MyRst.Fields.Count + 97) & "1").Value = "Итого"
    mysheet.Cells(m + 1 & ",1").Select
    With myOlApp.Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
      .Weight = xlThin
        .ColorIndex = 1
    End With
    With myOlApp.Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With myOlApp.Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
   ' ---------------------------------------------------------
 
For i =  98  To MyRst.RecordCount +  98 
    mysheet.Range(Chr( 97  + MyRst2.Fields.Count) & (i -  96 )).Formula = "=SUM($" & Chr( 98 ) & "$" & (i -  96 ) & ":$" & Chr(MyRst2.Fields.Count -  2  +  98 ) & "$" & (i -  96 ) & ")"
Next i
MyRst2.Close
Set MyRst2 = Nothing
'-----------------------------------------------------------------------
'+++++++++++++ Изменение шрифта названий задач+++++++++++++++++++++++++++++++
ct =  2 
Do Until MyRst.EOF
   If MyRst![type_balance] =  1  Then
    mysheet.Cells(ct,  1 ).Select
    myOlApp.Selection.Font.Bold = True
    myOlApp.Selection.Font.Italic = True
    End If
ct = ct +  1 
MyRst.MoveNext
Loop
MyRst.Close
'-------------------------------------------------------------
    For i = 98 To m + 96
'=============================================================
    strSum = "select * from balance where (level not like '%.%') and (level<>'0')"
    Set MyRst2 = New ADODB.Recordset
    MyRst2.Open strSum, strcon, adOpenDynamic, adLockOptimistic, adCmdText
    strOS = ""
    While Not MyRst2.EOF
        strN = mysheet.Cells.Find(MyRst2!name_balance).Address
        MyRst2.MoveNext
        strOS = "$" & Chr(i) & Mid(strN,  3 , Len(strN) -  2 ) & ","
    Wend
    mysheet.Range(Chr(i) & nRows +  1 ).Formula = "=SUM(" & strOS & ")"
'=============================================================
    Set MyRst = New ADODB.Recordset
    MyRst.Open "select * from balance", strcon, adOpenStatic, adLockReadOnly
    
While Not MyRst.EOF
    
    If MyRst!type_balance = 1 Then
    strOS = mysheet.Cells.Find(MyRst!name_balance).Address
    strSql = "select * from balance where balance.level like '" & MyRst!Level & ".%" & "'And level_balance=(" & MyRst!level_balance + 1 & ");"
    Set MyRst2 = New ADODB.Recordset
    MyRst2.Open strSql, strcon, adOpenDynamic, adLockOptimistic, adCmdText
    strST = ""
     strN = ""
While Not MyRst2.EOF
    strN = mysheet.Cells.Find(MyRst2!name_balance).Address
    MyRst2.MoveNext
    If Len(strN) > 0 Then
    strST = strST & "$" & Chr(i) & Mid(strN, 3, Len(strN) - 2) & ","
    End If
        
Wend
    MyRst2.Close
    If Len(strST) > 0 Then
        mysheet.Range(Chr(i) & Mid(strOS, 4, Len(strOS) - 2)).Formula = "=SUM(" & strST & ")"
    End If
End If
    MyRst.MoveNext
Wend
MyRst.Close
Next i
'Set MyRst = Nothing
'+++++++++ Установка шрифта+++++++++++++++
mysheet.Cells.Select
    With myOlApp.Selection.Font
        .Name = "Arial"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
    End With
' --------------------------Сетка и формат ячеек(красный, если отрицательное, "-",если- 0)-------------------------------------
 
    myOlApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    myOlApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With myOlApp.Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myOlApp.Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myOlApp.Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myOlApp.Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myOlApp.Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myOlApp.Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
mysheet.Cells.Select
    With myOlApp.Selection
    .NumberFormat = "###,###;[red]-### ###;-"
    End With
    mysheet.Range("a1").Value = "Задачи"
'++++++++++++++++++++++
mysheet.Range("a" & nRows + 1 & ":" & Chr(m + 97) & nRows + 1).Select
    With myOlApp.Selection.Font
    .Size = 12
    .Bold = True
    End With
            
' -------- Скрываем ненужное-------------
 
'---Справа-------------
If Me!EX_Group = False Then
mysheet.Rows(nRows + 2 & ":" & nRows + 2).Select
   mysheet.Range(myOlApp.Selection, myOlApp.Selection.End(xlDown)).Select
    myOlApp.Selection.EntireRow.Hidden = True
End If
' ---Снизу--------------
 
   mysheet.Columns(Chr(m +  98 ) & ":" & Chr(m +  98 )).Select
    mysheet.Range(myOlApp.Selection, myOlApp.Selection.End(xlToRight)).Select
    myOlApp.Selection.EntireColumn.Hidden = True
' --------------------------------------
 
MyWo.save
Set mysheet = Nothing
MyWo.Close
Set MyWo = Nothing
myOlApp.Quit
Set myOlApp = Nothing
strcon.Close
Set strcon = Nothing
End Sub