-Поиск по дневнику

Поиск сообщений в rss_sql_ru_access_programming

 -Подписка по e-mail

 

 -Постоянные читатели

 -Статистика

Статистика LiveInternet.ru: показано количество хитов и посетителей
Создан: 16.03.2006
Записей:
Комментариев:
Написано: 4


Вывод запроса в excel

Воскресенье, 31 Мая 2015 г. 16:42 + в цитатник
Пытаюсь вывести запрос в шаблон excel, по введенному полю Год. В итоге выводит пустые значения, хотя запрос рабочий:
SELECT Otr_organ.Naimenovanie, Uslugi.Naimenovanie, Uslugi.Adm_reglament, SUM(Monitoring.Kol_vo_zayaviteley) AS [Sum-Kol_vo_zayaviteley1], SUM(Monitoring.Kol_vo_predost_uslug) AS [Sum-Kol_vo_predost_uslug], SUM(Monitoring.Vsego_okazano_uslug_el) AS [Sum-Vsego_okazano_uslug_el]
FROM ((Otr_organ INNER JOIN Users ON Otr_organ.ID_otr_organa = Users.ID_user) INNER JOIN Uslugi ON Otr_organ.ID_otr_organa = Uslugi.ID_otr_organ) INNER JOIN Monitoring ON Uslugi.ID_uslugi = Monitoring.ID_uslugi
WHERE (((Users.ID_user)=[Код]) AND ((Monitoring.God)=[Год]))
GROUP BY Otr_organ.Naimenovanie, Uslugi.Naimenovanie, Uslugi.Adm_reglament;

Сам код вывода в excel:
Private Sub Кнопка48_Click()
Dim xlSheet As Excel.Worksheet
Dim wbTarget As Workbook
Dim xlApp As Excel.Application
Dim fileXLT As String, fileXLS As String, strQry As String
Dim rs As ADODB.Recordset
Dim MyQueryTable As Excel.QueryTable
Dim obj As Excel.Range
Dim strMax As String
Dim a As Variant
Dim b As Variant
Dim c As Variant
 
    'Определяем имена шаблона и документа
    fileXLT = CurrentProject.Path & "\Мониторинг_год.xltm"
    fileXLS = CurrentProject.Path & "\Мониторинг_год.xlsx"
 
    If Dir(fileXLS) <> "" Then
        If MsgBox("Документ с таким именем ранее уже был создан. Заменить его?", vbYesNo, "admin") = vbNo Then
            'если выбрали нет (не заменять), тогда просто открываем документ
            Set xlApp = CreateObject("Excel.Application")
            With xlApp
                .Workbooks.Open fileXLS
                .Visible = True
            End With
            Set xlApp = Nothing
        Else
            'если выбрали да - удаляем файл
            fDeleteFile (fileXLS)
            GoTo lab 'и переходим к созданию нового документа
        End If
    Else
lab:
        'вставляем таблицу из запроса
        'в шаблоне пишем в нужном месте метку ZT - с нее начнется вставка данных таблицы
         a = Forms!MainForm!Spisok' поле с кодом пользователя
         c = Forms!MonitoringExcel!Date_god' поле ввода года
         Z = Forms!Invisible_form!plStatus 'Статус
    If Z = "Admin" Then' запрос для админа с 1 параметром без выбора отраслевого орагана/кода пользователя
        strQry = "SELECT Otr_organ.Naimenovanie, Uslugi.Naimenovanie, Uslugi.Adm_reglament, Sum(Monitoring.Kol_vo_zayaviteley) AS [Sum-Kol_vo_zayaviteley1], Sum(Monitoring.Kol_vo_predost_uslug) AS [Sum-Kol_vo_predost_uslug], Sum(Monitoring.Vsego_okazano_uslug_el) AS [Sum-Vsego_okazano_uslug_el] FROM ((Otr_organ INNER JOIN Users ON Otr_organ.ID_otr_organa = Users.ID_user) INNER JOIN Uslugi ON Otr_organ.ID_otr_organa = Uslugi.ID_otr_organ) INNER JOIN Monitoring ON Uslugi.ID_uslugi = Monitoring.ID_uslugi WHERE (((Monitoring.God) = ('" & с & "'))) GROUP BY Otr_organ.Naimenovanie, Uslugi.Naimenovanie, Uslugi.Adm_reglament;"
    Else' запрос с 2 параметрами
        strQry = "SELECT Otr_organ.Naimenovanie, Uslugi.Naimenovanie, Uslugi.Adm_reglament, Sum(Monitoring.Kol_vo_zayaviteley) AS [Sum-Kol_vo_zayaviteley1], Sum(Monitoring.Kol_vo_predost_uslug) AS [Sum-Kol_vo_predost_uslug], Sum(Monitoring.Vsego_okazano_uslug_el) AS [Sum-Vsego_okazano_uslug_el] FROM ((Otr_organ INNER JOIN Users ON Otr_organ.ID_otr_organa = Users.ID_user) INNER JOIN Uslugi ON Otr_organ.ID_otr_organa = Uslugi.ID_otr_organ) INNER JOIN Monitoring ON Uslugi.ID_uslugi = Monitoring.ID_uslugi WHERE (((Users.ID_user) = (" & a & ")) And ((Monitoring.God) = ('" & с & "'))) GROUP BY Otr_organ.Naimenovanie, Uslugi.Naimenovanie, Uslugi.Adm_reglament"
        End If
        Set rs = New ADODB.Recordset
        rs.CursorLocation = adUseClient
        rs.Open strQry, CurrentProject.Connection, adOpenStatic, adLockReadOnly, adCmdText
        Set xlApp = CreateObject("Excel.Application") 'создаем объект Excel
        With xlApp
            .Workbooks.Open fileXLT 'Открываем файл
            .WindowState = xlMaximized 'разворачиваем во весь экран
            .Visible = True 'Отображаем документ
        Set xlSheet = .Sheets(1) 'переходим на первый лист
            With xlSheet
                Set obj = .Cells.Find("ZT") 'ищем ячейку с текстом ZT
                If Not obj Is Nothing Then
                    obj.Activate 'переходим в найденную ячейку - тут будет начало таблицы
                    obj.Clear 'очищаем ячейку
                    Set MyQueryTable = .QueryTables.Add(rs, Destination:=obj) 'цепляем данные из запроса
                    With MyQueryTable
                        .FieldNames = False
                        .Refresh 'закачиваем данные
                        .Application.Run "Test"
                    End With
                    xlSheet.Name = Forms!MonitoringExcel!Date_god
                    Set obj = Nothing
                End If
            End With
        End With
        'закрываем рекордсет и пременные
        rs.Close
        Set rs = Nothing
        
        Set xlSheet = Nothing
        Set MyQueryTable = Nothing
        Set xlApp = Nothing
If Z = "Admin" Then
    Forms!MainForm.Visible = True
    DoCmd.Close acForm, "MonitoringExcel"
        Else
    Forms!Monitoring.Visible = True
    DoCmd.Close acForm, "MonitoringExcel"
    End If
    End If
Exit Sub
 
Err_:
    MsgBox Err.Description  'сообщение об ошибке
    Err.Clear
    'Закрываем Excel (если открыта объектная переменная)
    If Not xlApp Is Nothing Then xlApp.Quit
End Sub
 
 
'удаление файла
Function fDeleteFile(strPath As String) As Boolean
On Error GoTo Err_
 
Dim fs
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    fs.DeleteFile strPath
    Set fs = Nothing
    fDeleteFile = True
Exit Function
 
Err_:
    MsgBox Err.Description, vbCritical, strPath
    Err.Clear
    fDeleteFile = False
End Function
 
'вставка данных в заданную ячейку
Function funInsertDate(ByVal Z As String, ByVal strDate As String)
On Error GoTo Err_
 
Dim obj As Excel.Range
Dim xlApp As Excel.Application
 
    Set xlApp = GetObject(, "Excel.Application")
    Set obj = xlApp.ActiveCell.Find(Z) 'ищем ячейку с заданным параметром Z текстом
    If Not obj Is Nothing Then
        With obj
            .Activate 'переходим в найденную ячейку
            .FormulaR1C1 = strDate 'вставляем данные
        End With
    End If
    Set obj = Nothing
    Set xlApp = Nothing
Exit Function
 
Err_:
    MsgBox Err.Description  'сообщение об ошибке
    Err.Clear
End Function


Буквально недавно, до того как я что то сделал неизвестное мне, при запуске вылазила ошибка "method add of object querytables failed" и указывала на эту строчку:
SET MyQueryTable = .QueryTables.ADD(rs, Destination:=obj) 'цепляем данные из запроса

Не знаю что уже и делать, код вывода рабочий... с другим запросом все выводит, а с этим не хочет...
Спасибо

http://www.sql.ru/forum/1159309/vyvod-zaprosa-v-excel


 

Добавить комментарий:
Текст комментария: смайлики

Проверка орфографии: (найти ошибки)

Прикрепить картинку:

 Переводить URL в ссылку
 Подписаться на комментарии
 Подписать картинку