Private Sub btnRasp_Click()
    'Создание подключения к базе
    Dim cnn As New ADODB.Connection
    cnn.ConnectionString = "Provider=MSDASQL.1;" _
    & "Data Source=PROD; User ID=yakunina; Password=soykatsy"
    cnn.CommandTimeout =  0 
    cnn.Open
    'Открываем набор данных
    Dim rs As New ADODB.Recordset
    rs.Open "select ovp.AD_OF_NAME, oo.NAME, oo.BANK_ACC, ovp.FEE_YEAR, oo.RECV_DS, fi.NAME, " _
    & "ovp.ORGNAME , oo.Code, ovp.ORGCODE, oo.AMND_DATE, oo.AMND_STATE, ovp.AMND_STATE " _
    & "from ows.client cl, ows.service s, ows.trans_subtype ts, ows.trans_type tt, ows.acnt_contract acc, " _
    & "ows.contr_status cs, ows.acnt_contract ac, ows.f_i fi, ows.contr_subtype cst, ows.opt_v_product ovp, " _
    & "ows.appl_product ap, ows.serv_pack sp, ows.opt_organisation oo " _
    & "where fi.ID = ap.f_i and fi.amnd_state = 'A' and fi.id = '1' and ap.pcat = 'C' " _
    & "and ap.con_cat = 'C' and ap.amnd_state = 'A' and ac.product = ap.internal_code " _
    & "and ac.amnd_state = 'A' and ac.CON_CAT = 'C' and ac.CCAT ='P' and to_date(ac.card_expire,'YYMM') > sysdate-30 " _
    & "and substr(ac.card_expire,3,2) = to_char(trunc(sysdate-30, 'MM'), 'MM') and cs.id = ac.contr_status " _
    & "and cs.amnd_state = 'A' and cs.external_code not in ('14', 'CB', 'CT', 'CU') and cl.id = ac.client__id " _
    & "and cl.amnd_state = 'A' and ac.CONTR_SUBTYPE__ID = cst.id and cst.AMND_STATE = 'A' " _
    & "and months_between(to_date(ac.card_expire,'YYMM'), trunc(sysdate-30, 'MM'))/12 < cst.EXPIRE_FOR_NEW/12 " _
    & "and months_between(to_date(ac.card_expire,'YYMM'), trunc(sysdate-30, 'MM'))/12 > 0 " _
    & "and acc.id = ac.acnt_contract__oid and acc.amnd_state = 'A' and ap.INTERNAL_CODE = ovp.APPL_PRODUCT " _
    & "and ovp.AMND_STATE = 'A' and sp.id = ap.service_pack and sp.amnd_state = 'A' and sp.name like '%-ZP%' " _
    & "and sp.name not like '%-ZP7%' and s.serv_pack__oid = ap.service_pack and s.amnd_state = 'A' " _
    & "and s.trans_type_t = ts.id and ts.amnd_state = 'A' and ts.trans_type__oid = tt.id and tt.amnd_state = 'A' " _
    & "and tt.name = 'Card Fee Yearly' and s.fee_base < 0.01 and ovp.ORGCODE = oo.code and oo.amnd_state = 'A' " _
    & "group by ovp.AD_OF_NAME, oo.NAME, oo.BANK_ACC, ovp.FEE_YEAR, oo.RECV_DS, fi.NAME, " _
    & "ovp.ORGNAME , oo.Code, ovp.ORGCODE, oo.AMND_DATE, oo.AMND_STATE, ovp.AMND_STATE " _
    & "order by fi.name, ovp.ad_of_name, oo.name", cnn
    
    Dim arrayRows As Variant, arrayRowsRst As Variant
    
    Dim intRow As Integer, intRst As Integer

    Dim intRows As Integer, intRowsRst As Integer, intItog As Integer
    
    Dim strClientName As String, strFileName As String, strFee As String, strItog As String
    
    Dim strFeeType As String, strUserFIO As String
    
    Dim intLoopRow As Integer, intLoopCol As Integer
    Dim lenLastName As Integer
    Dim Month1Day As Date
    
    Dim ObjWord As Variant
    Dim PathDOT As String
    
    'Создаем объект Word
    Set ObjWord = New Word.Application
    PathDOT = "C:"
    Dim Doc As Document
    'Записываем ФИО исполнителя в переменную
    lenLastName = InStr(Application.UserName, " ")
    strUserFIO = Left(Application.UserName, lenLastName) & Application.UserInitials
    'Определяем первый рабочий день месяца
    Month1Day = CDate("01." & Month(Date) & "." & Year(Date))
    If Weekday(Month1Day) =  1  Then
        Month1Day = Month1Day +  1 
    ElseIf Weekday(Month1Day) =  7  Then
        Month1Day = Month1Day +  2 
    End If
    'Находим число записей в наборе
    rs.MoveFirst
    intRows =  0 
    Do While Not rs.EOF
        intRows = intRows +  1 
        rs.MoveNext
    Loop
    rs.MoveFirst
    'Получаем массив записей
    arrayRows = rs.GetRows(intRows)
    'Объявляем набор данных
    Dim rst As New ADODB.Recordset
    'Объявляем таблицу
    Dim tblList As Table
    'Проход по записям массива
    For intLoopRow =  0  To intRows -  1 
        'Создаем новый документ на основе шаблона
        Set Doc = Nothing
        Set Doc = ObjWord.Documents.Add(PathDOT & "\" & "Распоряжение.doc")
        ObjWord.Visible = True
                'Запрашиваем данные из базы
                rst.Open "select cl.last_nam last_name, cl.first_nam first_name, cl.father_s_nam father_s_name, " _
                & "substr(ac.contract_number,1,6) || '******' || substr(ac.contract_number,12,4) contract_number, " _
                & "ovp.fee_year, ovp.curr from ows.client cl, ows.service s, ows.trans_subtype ts, ows.trans_type tt, ows.acnt_contract acc, " _
                & "ows.contr_status cs, ows.acnt_contract ac, ows.f_i fi, ows.contr_subtype cst, ows.opt_v_product ovp, ows.appl_product ap, " _
                & "ows.serv_pack sp, ows.opt_organisation oo where fi.ID = ap.f_i and fi.amnd_state = 'A' and ap.pcat = 'C' " _
                & "and ap.con_cat = 'C' and ap.amnd_state = 'A' and ac.product = ap.internal_code " _
                & "and ac.amnd_state = 'A' and ac.CON_CAT = 'C' and ac.CCAT ='P' and to_date(ac.card_expire,'YYMM') > sysdate-30 " _
                & "and substr(ac.card_expire,3,2) = to_char(trunc(sysdate-30, 'MM'), 'MM') and cs.id = ac.contr_status " _
                & "and cs.amnd_state = 'A' and cs.external_code not in ('14', 'CB', 'CT', 'CU') and cl.id = ac.client__id " _
                & "and cl.amnd_state = 'A' and ac.CONTR_SUBTYPE__ID = cst.id and cst.AMND_STATE = 'A' " _
                & "and months_between(to_date(ac.card_expire,'YYMM'), trunc(sysdate-30, 'MM'))/12 < cst.EXPIRE_FOR_NEW/12 " _
                & "and months_between(to_date(ac.card_expire,'YYMM'), trunc(sysdate-30, 'MM'))/12 > 0 " _
                & "and acc.id = ac.acnt_contract__oid and acc.amnd_state = 'A' and ap.INTERNAL_CODE = ovp.APPL_PRODUCT " _
                & "and ovp.AMND_STATE = 'A' and sp.id = ap.service_pack and sp.amnd_state = 'A' and sp.name like '%-ZP%' " _
                & "and sp.name not like '%-ZP7%' and s.serv_pack__oid = ap.service_pack and s.amnd_state = 'A' " _
                & "and s.trans_type_t = ts.id and ts.amnd_state = 'A' and ts.trans_type__oid = tt.id and tt.amnd_state = 'A' " _
                & "and tt.name = 'Card Fee Yearly' and s.fee_base < 0.01 AND ovp.fee_year = '" + CStr(arrayRows( 3 , intLoopRow)) + "' " _
                & "and ovp.ORGCODE = oo.code and oo.amnd_state = 'A' AND oo.name = '" + CStr(arrayRows( 1 , intLoopRow)) + "' " _
                & "order by last_name, first_name, father_s_name", cnn
        'Находим число записей в наборе
        If Not rst.EOF Then
            rst.MoveFirst
            intRowsRst =  0 
            Do While Not rst.EOF
                intRowsRst = intRowsRst +  1 
                rst.MoveNext
            Loop
            rst.MoveFirst
            arrayRowsRst = rst.GetRows(intRowsRst)
        Else
            intRowsRst =  0 
        End If
        'Вводим данные из массива в шаблон
        With ObjWord.ActiveDocument.Bookmarks
            .Item("OfficeCode").Range.Text = arrayRows( 0 , intLoopRow)
            .Item("CurrDate").Range.Text = Date
            .Item("Name").Range.Text = arrayRows( 1 , intLoopRow)
            
            If arrayRows( 2 , intLoopRow) <> "Null" Then
                .Item("BankAcc").Range.Text = "№ " & arrayRows( 2 , intLoopRow)
            Else
                .Item("BankAcc").Range.Text = ""
            End If
            Select Case arrayRowsRst( 5 ,  0 )
            Case  810 
                strFeeType = "рублей 00 коп."
            Case  840 
                strFeeType = "долларов 00 центов"
            Case  978 
                strFeeType = "евро 00 евроцентов"
            End Select
            .Item("FeeYear").Range.Text = intRowsRst * CInt(arrayRows( 3 , intLoopRow))
            If CInt(arrayRows( 3 , intLoopRow)) =  0  Then
                .Item("FeeYears").Range.Text = "ноль " + strFeeType
            Else
                .Item("FeeYears").Range.Text = TextSum(intRowsRst * CInt(arrayRows( 3 , intLoopRow)), arrayRowsRst( 5 ,  0 ))
            End If
            .Item("CardCount").Range.Text = intRowsRst
            .Item("Month1Day").Range.Text = Month1Day
            If arrayRows( 4 , intLoopRow) <> "Null" Then
                .Item("NoteDoc").Range.Text = arrayRows( 4 , intLoopRow)
            Else
                .Item("NoteDoc").Range.Text = "RDF" '?What needs?
            End If
            .Item("FIO").Range.Text = strUserFIO
        End With
        'Переходим в конец документа
        Doc.ActiveWindow.Selection.EndKey Unit:=wdStory
        Doc.ActiveWindow.Selection.InsertBreak Type:=wdPageBreak
        Doc.ActiveWindow.Selection.Font.Size =  12 
        'Создаем пустую таблицу
        Set tblList = Doc.Tables.Add(Doc.ActiveWindow.Selection.Range, NumRows:=intRowsRst +  2 , NumColumns:= 4 )
        With tblList
            If .Style <> "Сетка таблицы" Then
                .Style = "Сетка таблицы"
            End If
            .ApplyStyleHeadingRows = True
            .ApplyStyleLastRow = False
            .ApplyStyleFirstColumn = True
            .ApplyStyleLastColumn = False
            .ApplyStyleRowBands = True
            .ApplyStyleColumnBands = False
        End With
        tblList.Select
        'Заполнение таблицы
        intItog =  0 
        tblList.Columns( 1 ).Width =  45 
        tblList.Columns( 2 ).Width =  250 
        tblList.Columns( 3 ).Width =  110 
        tblList.Columns( 4 ).Width =  65 
        tblList.Cell( 1 ,  1 ).Range.InsertAfter "№ п/п"
        tblList.Cell( 1 ,  2 ).Range.InsertAfter "ФИО"
        tblList.Cell( 1 ,  3 ).Range.InsertAfter "Номер карты"
        tblList.Cell( 1 ,  4 ).Range.InsertAfter "Комиссия"
        If intRowsRst <>  0  Then
                    For intRst =  0  To intRowsRst -  1 
                        strClientName = CStr(arrayRowsRst( 0 , intRst)) + " " + CStr(arrayRowsRst( 1 , intRst))
                        If arrayRowsRst( 2 , intRst) <> "Null" Then
                            strClientName = strClientName + " " + CStr(arrayRowsRst( 2 , intRst))
                        End If
                        Select Case arrayRowsRst( 5 , intRst)
                        Case  810 
                            strFeeType = "RUR"
                        Case  840 
                            strFeeType = "USD"
                        Case  978 
                            strFeeType = "EUR"
                        End Select
                        strFee = CStr(arrayRowsRst( 4 , intRst)) + " " + strFeeType
                        tblList.Cell(intRst +  2 ,  1 ).Range.InsertAfter intRst +  1 
                        tblList.Cell(intRst +  2 ,  2 ).Range.InsertAfter strClientName
                        tblList.Cell(intRst +  2 ,  3 ).Range.InsertAfter arrayRowsRst( 3 , intRst)
                        tblList.Cell(intRst +  2 ,  4 ).Range.InsertAfter strFee
                        intItog = intItog + CInt(arrayRowsRst( 4 , intRst))
                    Next
                    strItog = CStr(intItog) + " " + strFeeType
                    tblList.Cell(intRst +  2 ,  2 ).Range.InsertAfter "Итого"
                    tblList.Cell(intRst +  2 ,  4 ).Range.InsertAfter strItog
        End If
        'Закрываем набор данных
        rst.Close
        'Переходим в начало документа
        Doc.ActiveWindow.Selection.HomeKey Unit:=wdStory
        'Сохраняем документ
        strFileName = CStr(arrayRows( 6 , intLoopRow)) + " fee " + CStr(arrayRows( 3 , intLoopRow)) + ".doc"
        Doc.SaveAs (strFileName)
    Next
    
    Set ObjWord = Nothing
    'Закрываем набор данных
    rs.Close
    'Закрываем соединения
    cnn.Close
End Sub