Перенос данных из Access в Excel - Полезные утилиты - Программирование в Access - Каталог статей - Отдел информационных технологий ГКБ №29
Пятница, 09.12.2016, 07:56
Приветствую Вас Гость | Регистрация | Вход

Отдел информационных технологий ГКБ №29 г.Новокузнецк

Меню сайта
Категории раздела
Полезные утилиты [5]
Поиск
Наш опрос
Как Вы оцениваете качество материалов?
Всего ответов: 28
Полезные ссылки
  • Официальный блог
  • Сообщество uCoz
  • Технологии программирования
  • Сайт о здоровье
  • Друзья сайта
  • КМИАЦ Новокузнецка
  • Интернет университет
  • Дистанционное обучение
  • Статистика
    Деловая сеть Кемерово и Кемеровская область. Жёлтые страницы, телефонный справочник и каталог компаний, товаров и услуг. Rambler's Top100
    Онлайн всего: 1
    Гостей: 1
    Пользователей: 0
    Погода
    Яндекс.Погода

    Каталог статей

    Главная » Статьи » Программирование в Access » Полезные утилиты

    Перенос данных из Access в Excel
    Перенос данных из Access в Excel, стал одной из стандартных задач, решаемых программистами VBA. Стараясь делать передачу данных быстрой, надежной и универсальной я натолкнулся на некоторые интересные методы и особенности, которыми считаю нужным поделиться, рассчитывая получить в ответ новые идеи а также в надежде на то, что некоторое количество людей сможет избежать моих ошибок.
    Тестируемые методы:
    Ниже приведен список методов с текстом кода и комментариями, преимуществами и недостатками:
    Обратите внимание на следующее: во-первых, это - не все возможные методы, я с удовольствием приму и протестирую любой метод, не указанный здесь, во-вторых - не все методы до конца оптимизированы (я также буду рад любым предложениям по изменениям, направленным на улучшение работы приведенных способов), и наконец, возможно имеются другие доступные методы и способы в более поздних версиях MS Office - я ограничился только MS Office 97.
    • Метод ADODB recordset 
    • Метод DAO recordset 
    • Метод OutputTo 
    • Метод TransferSpreadsheet 
    • Метод Copyfromrecordset 
    • Метод QueryTable 
    • Метод ADO + Clipboard 
    • Метод RunCommand + Clipboard
    • Результаты тестирования 
    Постановка задачи:
    Задача состояла в том, чтобы измерить скорость различных методов помещения результата выполнения строки sql на рабочем листе Excel. Сразу оговоримся, что не все процедуры равны в этом отношении, так как некоторые из них (например, OutputTo), создают xls файл на диске, в то время как другим (RunCommand например) файл необходимо сохранить после создания. С другой стороны, первый тип методов не может создать рабочую книгу с множеством листов или помещать данные в указанном месте рабочего листа - вы должны "собрать" листы в одной рабочей книге после помещения их на диск и обработать результаты. Также различные методы различаются по их чувствительности к ошибкам, возможно присутствующим в наборе записей.
    Таким образом задача испытаний формулируется следующим образом: "Поместить результат выполнения cтроки sql на отдельный лист Excel. Как только данные находятся на рабочем листе, задача считается выполненной"
    Способ тестирования:
    Для испытаний использовались Microsoft Access / Excel 97 SR-2. Под WinNT 4.0 на машине Pentium Intel IV 2200, 256МБ, 30GB. Данные передаются из локальной таблицы, содержащейся 13 полей и 10000 записей на вновь создаваемый рабочий лист Excel.
    Тестовая процедура:
    ________________________________________
    Sub Test() 
    Dim XL As Object
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim rs As Recordset
    Dim i As Integer
    Dim j As Integer
    Dim f1 As String
    Dim sql As String
    Dim n As Long, m As Long
    Dim x As Long
    Dim y As Long
    Dim Dummy As Variant
    Dim a As Double
    Dim arr As Variant

    arr = Array(10, 50, 100, 300, 500, 1000, 2000, 3000, 5000, 10000)
    'array to limit record number

    Set XL = CreateObject("excel.application")

    XL.SheetsInNewWorkbook = 1

    Set WB = XL.Workbooks.Add
    Set WS = WB.Worksheets(1)
    For i = 1 To 10

      sql = "SELECT TOP " & arr(i - 1) & " IIf([ID]='ID',1/0,0),* FROM Table"
      'iif используется для генерации ошибки деления на ноль

      x = 1
      y = 1

      For j = 1 To 10
      a = timer

      Call SKXLOut(WS, sql)
      ' здесь тестовая процедура вызывается 10 раз
      CurrentDb.Execute ("INSERT INTO Table3 (Procid, [Time], Rows) Values( 9," & _
      ((timer - a) / 60) & "," & arr(i - 1) & ");")
      Dummy = SysCmd(acSysCmdSetStatus, i & ":" & arr(i - 1) & "(" & j & ")")
      Next j

    Next i

    Dummy = SysCmd(acSysCmdClearStatus)

    WB.Close False
    XL.Quit

    End Sub
    ________________________________________

    Позже, результаты были усреднены.
    Описания методов:

    Метод ADODB recordset 
    Общее описание:
    Очень быстрый и мощный.
    Особенности: вы должны определить x и y координаты верхней левой ячейки, и в переменные n и m, переданные по ссылке вы получаете высоту и ширину полученного диапазона. Установите значение переменной Headers равной True, если вам нужны в заголовки столбцов.
    Этот метод - ошибко-независимый - ошибки игнорируется.
    Детали этого решения - ADODB recordset - позволяет вернуть значения полей записи запроса и поместить их в массив, который затем транспонируется и выводится в MS Excel Range . 
    Требования:
    Требуются ссылки на библиотеку MS Excel object library (необязательно, - используется, толко для проверки синтаксиса. Вы можете не устанавиливать ссылку на Excel, описав переменную WS как Object) также требуется ссылка на библиотеку ActiveX Data Objects Library
    Преимущества:
    Быстрый, универсальный, надежный.
    Недостатки:
    Этот метод весьма замедлен необходимостью транспонировать матрицу, полученную методом getrows. К сожалению, getrows помещает значения в транспонированном виде. Если этого удастся избежать каким либо способом, скорость значительно увеличится.
    Code:
    ________________________________________
    Public Function TXLOut (sql As String, Optional WS As Worksheet = Nothing, Optional ByRef x As Long = 1, Optional ByRef y As Long = 1, Optional ByRef n As Long = 1, Optional ByRef m As Long = 1, Optional Headers As Boolean = True) As Worksheet
    'Turbo Version
    'Notice, that you need References to ActiveX Data Objects Library and Microsoft Excel Objects Library
    Dim a As Variant
    Dim rs As New ADODB.Recordset
    Dim con As New ADODB.Connection
    Dim c() As Variant
    Dim i, j, l, k As Integer

    rs.Open sql, "Driver={Microsoft Access Driver (*.mdb)};Dbq=" & CurrentDb.Name & ";", adOpenForwardOnly, adLockOptimistic

    a = rs.GetRows()

    ReDim c(UBound(a, 2), UBound(a, 1))

    ' Here comes matrix transposition
    For k = 0 To UBound(a, 1) 
      For j = 0 To UBound(a, 2) 
      c(j, k) = a(k, j)
      Next j
    Next k

    n = UBound(a, 2) + 1
    m = UBound(a, 1) + 1

    WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)) = c

    'Here columns headers are put if necessary
    If Headers Then
      WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)).rows(1).Insert
      For j = 0 To m - 1
      WS.Cells(y, j + x).Value = rs.Fields(j).Name
      Next j
    End If

    rs.Close

    Exit Function

    whoops:
    Resume Next
    End Function 
    ________________________________________

     
    Метод DAO recordset 
    Общее описание:
    Фактически это - вариация версии ADO+recordset метода и как таковая имеет несколько недостатков.
    Особенности: Вы должны определить x и y - верхней левой ячейки, и в переменные n и m, вы получаете высоту и ширину полученного диапазона. Установите значение переменной Headers равной TRUE, если Вам нужны в заголовки столбцов.
    Этот метод - ошибко-независимый - ошибки игнорируется.
    Детали этого решения - DAO recordset - позволяет вернуть значения полей записи запроса и поместить их в массив, который затем транспонируется и выводится в диапазон ячеек Excel. 
    Требования:
    Требуется ссылка на библиотеку MS Excel object library (необязательно, - только, чтобы иметь правильный синтаксис. Вы можете не устанавливать ссылку на EXCEL, описав переменную WS как Object) 
    Преимущества:
    Не нуждается в ссылке на библиотеку ADO. 
    На малом количестве строк (<50) показывает лучший результат (см. график).
    В этой процедуре сделаны некоторые изменения. Если Вы переносите большое количество данных (приблизительно 30000 строк для моей машины), Вы можете выйти за пределы памяти (out of memory), и даже если компьютер не зависнет, это будет медленней, чем сделать перенос 3 раза по 10000 записей. Так что эта функция проверяет количество записей и если их более 10000, выводит их по частям.
    Недостатки:
    Этот метод зависит от количества ошибок в рекордсете. В отличие от ADO recordset, метод GetRows библиотеки DAO, когда встречается ошибка в любом поле, прекращает работать и не генерирует никакой ошибки - данные потеряны, и Вы ничего об этом не знаете. По этому, вместо rs.getrows в этой процедуре использована автономную процедуру GetR, которая использует getrows, и в случае ошибок читает запись поле за полем.
    Code:
    ________________________________________
    Public Function XLOut(sql As String, Optional WS As Worksheet = Nothing, Optional ByRef x As Long = 1, Optional ByRef y As Long = 1, Optional ByRef n As Long = 1, Optional ByRef m As Long = 1, Optional Headers As Boolean = True) As Worksheet

    Dim a As Variant
    Dim rs As Recordset
    Dim l, i, j As Integer

    Set rs = CurrentDb.OpenRecordset(sql)
    If Not rs.EOF Then
      rs.MoveLast
      rs.MoveFirst
    End If

    n = rs.RecordCount
    m = rs.Fields.Count


    If n <= 10000 Then

      a = GetR(rs, rs.RecordCount)

      WS.Range(WS.Cells(y, x), WS.Cells(UBound(a, 1) + y, UBound(a, 2) + x)) = a
    Else

      For i = 1 To n \ 10000
      a = GetR(rs, 10000)

      WS.Range(WS.Cells((i - 1) * 10000 + y, x), WS.Cells((i - 1) _
      * 10000 + UBound(a, 1) + y, UBound(a, 2) + x)) = a
      Next i

      a = GetR(rs, n Mod 10000)
      WS.Range(WS.Cells(n - (n Mod 10000) + y, x), WS.Cells(n + y, UBound(a, 2) + x)) = a

    End If

    If Headers Then
      WS.Cells(y, x).EntireRow.Insert
      For j = 0 To rs.Fields.Count - 1
      WS.Cells(y, j + x).Value = rs.Fields(j).Name
      Next j
    End If

    Set rs = Nothing

    Set XLOut = WS
    End Function 
    ________________________________________

    Function GetR(rs As Recordset, n As Long) As Variant
    Dim a As Variant
    Dim b() As Variant
    Dim c() As Variant
    Dim i, j, l, k As Integer
    Dim num As Integer
    Dim hnum As Integer
    On Error GoTo whoops
    l = rs.Fields.Count
    ReDim a(l - 1, 0)
    num = 0
    While Not rs.EOF
      a = rs.GetRows(n)

      If Not rs.EOF Then
      j = UBound(a, 2) + 1
      ReDim Preserve a(l - 1, j)
      For i = 0 To l - 1
      a(i, j) = rs.Fields(i).Value
      Next i
      rs.MoveNext
      End If

      num = num + 1
      ReDim Preserve b(num)
      b(num) = a
    Wend

    ReDim c(n - 1, l - 1)

    hnum = 0
    For i = 1 To num 
      For k = 0 To UBound(b(i), 2) 
      For j = 0 To l - 1 'iiey
      c(hnum, j) = b(i)(j, k)
      Next j
      hnum = hnum + 1
      Next k
    Next i

    GetR = c

    Exit Function
    whoops:
    ' Debug.Print "Recordset Error!"
    Resume Next

    End Function 
    ________________________________________

     
    Метод OutputTo

    Общее описание:
    Довольно быстро для выбранного количества строк - см. график и очень простой метод.
    Ошибки игнорируются.
    Требования: необходимо иметь сохраненный запрос "Bolvanka" (или с любым другим названием).
    Преимущества:
    Простой, быстрый, свободный от ошибок метод. 
    Преимуществом можно считать и то, что Вы получаете готовый файл на диске.
    Недостатки:
    Вы можете вывести только один лист в один файл. 
    Вы можете поместить результаты запроса только начиная с верхней левой ячейки листа
    Вы не можете вывести данные без заголовков.

    Code:
    ________________________________________
    Function OTXLOut(sql As String)

    CurrentDb.QueryDefs("Bolvanka").sql = sql
    DoCmd.OutputTo acOutputQuery, "Bolvanka", acFormatXLS, "C:\Test.xls"

    End Function 
    ________________________________________


    Метод TransferSpreadsheet
    Общее описание:
    Это, наверное, самый быстрый способ (см. график), но он имеет серьезные недостатки.
    Требования: нeобходимо иметь сохраненный запрос "Bolvanka" (или с любым другим названием).
    Преимущества: 
    Наиболее быстрый, простой, вы получаете файл на диске.
    Недостатки:
    Вы можете поместить результаты запроса только начиная с верхней левой ячейки листа
    Если recordset содержит ошибку, Вы получите всплывающее сообщение об ошибке, которое я не смог подавить - так что это - едва ли хороший способ для автоматизации. Но я думаю, если предпринять меры к предотвращению ошибок и сборке файлов после вывода в одну рабочую книгу, этот способ будет самым быстрым, для небольшого количества строк.

    Code:
    ________________________________________
    > Function TDXLOut(sql As String)
    CurrentDb.QueryDefs("Bolvanka").sql = sql
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, "Bolvanka", "C:\Test.xls", True
    End Function 
    ________________________________________

    Метод Copyfromrecordset
    Общее описание:
    Это встроенный метод Excel для получения значений из recordset на рабочий лист.
    Требования: библиотека объектов MS Excel
    Перимущества:
    Простой. Данные могут быть помещены в любом месте страницы
    Недостатки:
    В Excel 97, метод принимает в качестве аргумента только DAO recordset. Как я уже упоминал, DAO recordset имеет очень неприятный дефект - при любой ошибке он обрезает данные до места ошибки, не выводя никаких сообщений об ошибке. Поэтому, если вы собираетесь использовать этот метод, вы должны проверять recordset на наличие ошибок перед или после вывода. Excel более поздних версий поддерживает ADO recordsets, который не содержит этого дефекта.
    Code:
    ________________________________________
    Function CFRXLOut(WS As Worksheet, sql As String)
    Dim rs As Recordset

    Set rs = CurrentDb.OpenRecordset(sql)
    WS.Cells(3,2).CopyFromRecordset rs

    End Function 
    ________________________________________

    Метод QueryTable
    Общее описание:
    QueryTables - простой способ получить данные из Access в Excel с использованием пользовательского интерфейса Excel. Это можно сделать и программно.
    Требования: библиотека объектов MS Excel
    Преимущества:
    Это - лучший метод, если Вы имеете, скажем, шаблон, с большим количеством форматирования и небольшим количеством данных. Вы обновляете QueryTables, уничтожаете их и сохраняете под другим именем.
    Недостатки:
    Как правило файлы с External Data не принято перемещать с машины на машину или посылать через электронную почту - если кто - то случайно обновит таблицы запроса на машине, которая не имеет необходимых источников данных, он получит ошибку. По этому, если Вы планируете передавать этот файл, Вы должны сделать QueryTables ("name") .Delete - чтобы данные были сохранены в файле Excel. Кроме того, этот метод медленен (см. График). 
    Code:
    ________________________________________
    Function QTXLOut(WS As Worksheet, sql As String)

    With WS.QueryTables.Add(Connection:=Array(Array( _
    "ODBC;DBQ=" & CurrentDb.Name & ";Driver={Microsoft Access Driver (*.mdb)};Dri" _
    ), Array("verId=25;FIL=MS Access;ImplicitCommitSync=Yes;MaxBufferSize=512;" & _
    MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UserCo" _
    ), Array("mmitSync=Yes;")), Destination:=WS.Range("A1"))
      .sql = Array(sql)

      .Refresh BackgroundQuery:=False

    End With

    End Function 
    ________________________________________

    Использование ADO + Clipboard
    Общее описание:
    При разработке этого метода, я думал, это - курьез, не более. Однако, полученные результаты показали, что это неожиданно хороший метод для небольшого (<500) количества записей.
    Требуются: ссылки на библиотеку MS Excel object library (необязательно, - нужно только, чтобы иметь правильный синтаксис. Вы можете не устанавливать ссылку на EXCEL, описав переменную WS как Object), библиотеку ActiveX Data Objects Library и MSForms Object library.
    Метод объединяет возможности ADO recordset, и MSForms Data Object. DataObject дает возможность взаимодействовать с буфером обмена (Clipboard). Мы заполняем буфер обмена строкой, где значения полей разделены CHR (9) и строки CHR (10), затем выполняем Paste. Есть способы ускорить эту процедуру, например использовать не DataObject, а API. Другой путь - использовать не заданный по умолчанию текстовый формат в SetText, а помещать в буфер обмена массив, что позволит на составлять строку.
    Преимущества:
    Быстро.
    Недостатки:
    Требуется 3 библиотеки. "умирает", если размер данных превышает 2 КБ (ограничения буфера обмена Windows).

    Code:
    ________________________________________
    Public Function CXLOut(sql As String, Optional WS As Worksheet = Nothing, Optional ByRef x As Long = 1, Optional ByRef y As Long = 1, Optional ByRef n As Long = 1, Optional ByRef m As Long = 1, Optional Headers As Boolean = True) As Worksheet
    'Clipboard version
    Dim a As Variant
    Dim rs As New ADODB.Recordset
    Dim con As New ADODB.Connection
    Dim ors As Recordset
    'Dim l, i, j As Integer
    Dim c As Variant
    Dim i, j, l, k As Integer
    Dim dum As String
    Dim ddo As New MSForms.DataObject


    rs.Open sql, "Driver={Microsoft Access Driver (*.mdb)};Dbq=" & CurrentDb.Name & ";", adOpenForwardOnly, adLockOptimistic

    dum = ""
    Do
      dum = dum + CStr(rs(0))
      For i = 1 To rs.Fields.Count - 1
      dum = dum + Chr(9) + CStr(Nz(rs(i)))
      Next i
      dum = dum + Chr(10)
      j = j + 1
      rs.MoveNext
    Loop While Not rs.EOF


    n = j
    m = rs.Fields.Count

    ddo.SetText (dum)
    ddo.PutInClipboard
    WS.Cells(1, 1).Activate
    WS.Paste
    'WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)) = Trans(a)

    If Headers Then
      WS.Range(WS.Cells(y, x), WS.Cells(n + y - 1, m + x - 1)).rows(1).Insert
      For j = 0 To m - 1
      WS.Cells(y, j + x).Value = rs.Fields(j).Name
      Next j
    End If

    rs.Close

    Exit Function
    whoops:
    Resume Next
    End Function 
    ________________________________________

    Использование RunCommand + Clipboard
    Общее описание:
    Один из моих первых экспериментов в той области. Худший вариант из всех
    Требования: сохраненный запрос, Microsoft excel object library (Optional)
    Недостатки: 
    Медленно и во время выполнения вы ничего не можете делать.
    Code:




    Набор функций для работы с MS EXCEL 
    (обращений: 6453 )

    Option Compare Database
    Option Explicit
    Option Base 0 
    ________________________________________

    Public ExcelApp As Object ' объявляется под Excel


    Public Function ExcelCreate(Optional ByVal pc_FromFileName As String = "", _
    Optional pl_Show As Boolean = False) As Integer
    ' Создаёт Excel-файл
    ' pc_FromFileName - имя открываемого файла
    ' pl_Show - делать ли видимым Excel-объект
    '
    ' Возвращает: 1 - Excel-файл создан успешно
    ' 0 - нет доступа к файлу (заблокирован путь) или файл (на основе которого создание) не существует
    ' -1 - ошибка запуска/наличия MS-Excel
    ' -2 - ошибка создания файла

    pc_FromFileName = Trim(pc_FromFileName)
    If Not pc_FromFileName = "" Then
      On Error GoTo err1
      If Len(Dir(pc_FromFileName)) < 1 Then
      ExcelCreate = 0
      MsgBox "Не существует файла " & pc_FromFileName & ", на основе которого должен быть создан новый!", vbCritical + vbOKOnly, " "
      Exit Function
      End If
    End If
    On Error GoTo 0
    If ExcelCheckApp(True) = False Then
    ExcelCreate = -1
    Exit Function
    End If

    On Error GoTo err2
    ExcelApp.DisplayAlerts = False
    With ExcelApp
      If Len(pc_FromFileName) < 1 Then
      .Workbooks.Add
      Else
      .Workbooks.Add (pc_FromFileName)
      End If
      .Visible = pl_Show
    End With
    ExcelCreate = 1
    Exit Function

    err1:
    ExcelCreate = 0
    MsgBox "Возможно нет доступа к файлу " & pc_FromFileName, vbCritical + vbOKOnly, " "
    Exit Function

    err2:
    ExcelCreate = -2
    MsgBox "Ошибка создания Excel-файла", vbCritical + vbOKOnly, " "
    Exit Function
    End Function 
    ________________________________________

    Public Function ExcelOpen(ByVal pc_FileName As String, _
      Optional pl_Show As Boolean = False, _
      Optional pl_ReadOnly As Boolean = False) As Integer
    ' Открывает Excel-файл
    ' pc_FileName - имя открываемого файла
    ' pl_Show - делать ли видимым Excel-объект
    ' pl_ReadOnly - (=True) открытие в режиме "Только чтение"
    '
    ' Возвращает: 1 - Excel-файл открыт успешно
    ' 0 - не указано имя открываемого файла
    ' -1 - нет доступа к файлу (заблокирован путь) или файл не существует
    ' -2 - ошибка запуска/наличия MS-Excel
    ' -3 - ошибка открытия файла

    pc_FileName = Trim(pc_FileName)
    On Error GoTo err1
    If pc_FileName = "" Then
    ExcelOpen = 0
    MsgBox "Укажите имя Excel-файла !", vbCritical + vbOKOnly, " "
    Exit Function
    ElseIf Len(Dir(pc_FileName)) < 1 Then
    ExcelOpen = -1
    MsgBox "Файла " & pc_FileName & " не существует!", vbCritical + vbOKOnly, " "
    Exit Function
    End If
    On Error GoTo 0
    If ExcelCheckApp(True) = False Then
    ExcelOpen = -2
    Exit Function
    End If

    On Error GoTo err2
    ExcelApp.DisplayAlerts = False
    With ExcelApp
      .Workbooks.Open pc_FileName, 0, pl_ReadOnly
      .Visible = pl_Show
    End With
    ExcelOpen = 1
    Exit Function

    err1:
    ExcelOpen = -1
    MsgBox "Возможно нет доступа к файлу " & pc_FileName, vbCritical + vbOKOnly, " "
    Exit Function

    err2:
    ExcelOpen = -3
    MsgBox "Ошибка открытия Excel-файла " & pc_FileName, vbCritical + vbOKOnly, " "
    Exit Function
    End Function 
    ________________________________________

    Public Function ExcelQuit() As Integer
    ' Закрывает Excel
    '
    ' Возвращает: 1 - успешное закрытие Excel 0 - нет
       
    Dim iiX As Integer, iiY As Integer

    If ExcelCheckApp(False) = False Then Exit Function
    On Error GoTo err1
    With ExcelApp
    iiY = .Workbooks.Count
      For iiX = 1 To iiY
      .ActiveWorkbook.Close (False)
      Next
      .Quit
    End With
    Set ExcelApp = Nothing
    ExcelQuit = 1
    Exit Function

    err1:
    ExcelQuit = 0
    End Function 
    ________________________________________

    Public Function ExcelSave(Optional ByVal pc_FileNameAs As String = "", _
      Optional pl_Close As Boolean = True) As Integer
    ' Сохраняет Excel-документ
    ' pc_FileNameAs - если указано, то сохранение файла будет выполняться под указанным именем
    ' pl_Close - закрытие документа после его сохранения
    '
    ' Возвращает: 1 - успешное сохранение Excel-документа
    ' 0 - ошибка сохранения Excel-файла
    ' -1 - ошибка при удалении предыдущей версии перед сохранением Excel-файла
    ' -2 - ошибка сохранения Excel-файла под указанным именем
    ' -3 - ошибка наличия MS-Excel/ отсутствия связи между глобальной объектной переменной ExcelApp и MS-Excel

    If ExcelCheckApp(False) = False Then
    ExcelSave = -3
    Exit Function
    End If
    pc_FileNameAs = Trim(pc_FileNameAs)
    With ExcelApp
      If Len(pc_FileNameAs) < 1 Then
      On Error GoTo err1
      .ActiveWorkbook.Save
      Else
      On Error GoTo err2
      If Len(Dir(pc_FileNameAs)) > 0 Then Kill pc_FileNameAs
      On Error GoTo err3
      .ActiveWorkbook.Saveas (pc_FileNameAs)
      End If
      If pl_Close Then .ActiveWorkbook.Close (False)
    End With

    ExcelSave = 1
    Exit Function

    err1:
    ExcelSave = 0
    MsgBox "Ошибка сохранения Excel-файла !", vbCritical + vbOKOnly, " "
    Exit Function
    err2:
    ExcelSave = -1
    MsgBox "Ошибка при удалении предыдущей версии перед сохранением Excel-файла " & _
    pc_FileNameAs, vbCritical + vbOKOnly, " "
    Exit Function
    err3:
    ExcelSave = -2
    MsgBox "Ошибка сохранения Excel-файла " & pc_FileNameAs, vbCritical + vbOKOnly, " "
    Exit Function
    End Function 
    ________________________________________

    Public Function ExcelRowColCount(Optional ByVal WhatCount As String = "Row", _
      Optional ByVal pu_Sheet As Variant = 1) As Long
    ' Возвращает: номер последнего заполненного столбца, если WhatCount="Column",
    ' иначе - номер последней заполненной строки в указанном pu_Sheet (номер или имя) листе
    ' или -1 - в случае неправильного задания параматра pu_Sheet
    ' или -2 - в случае отсутствия связи между глобальной объектной переменной ExcelApp и MS-Excel
    If ExcelCheckApp(False) = False Then
    ExcelRowColCount = -2
    Exit Function
    End If
    If VarType(pu_Sheet) = vbString Then pu_Sheet = Trim(pu_Sheet)
    If ExcelCheckExistSheet(pu_Sheet) Then
      If WhatCount = "COLUMN" Then
      ExcelRowColCount = ExcelApp.Worksheets(pu_Sheet).Cells.SpecialCells(11).Column ' 11=xlCellTypeLastCell
      Else
      ExcelRowColCount = ExcelApp.Worksheets(pu_Sheet).Cells.SpecialCells(11).Row
      End If
    Else
    ExcelRowColCount = -1
    End If
    End Function 
    ________________________________________

    Public Sub ExcelChangeCells(ByVal pu_SeekValue As Variant, _
      Optional ByVal pu_Sheet As Variant = 1, _
      Optional pl_SlowSeek As Boolean = False, _
      Optional ByVal pn_InColSeek As Long = 1, _
      Optional ByVal pn_RowStart As Long = 1, _
      Optional ByVal pn_RowEnd As Long = 0, _
      Optional ByVal pn_ApplayColStart As Integer = 1, _
      Optional ByVal pn_ApplayColEnd As Integer = 0, _
      Optional ByVal pn_Fontbold As Integer = -1, _
      Optional ByVal pc_BackColor As String = "", _
      Optional ByVal pc_ForeColor As String = "", _
      Optional ByVal pn_FontSize As Integer = 0, _
      Optional pu_NewValue As Variant)

    ' pu_SeekValue - искомое значение, допустимые типы значения:
    ' vbString, vbDate, vbDecimal, vbInteger, vbLong, vbDouble, vbSingle, vbBoolean

    ' pu_Sheet - номер или имя листа (если указан не верно, то данная процедура не выполняется)
    ' если вообще не указан, то данная процедура будет выполняться для первого листа

    ' pl_SlowSeek - если=True, то поиск по вхождению строки (только если в pu_SeekValue - символьное значение)
    ' иначе как равенство

    ' pn_InColSeek - в листе по колонке с каким номером вести поиск, если указан как < 1, или вообще не указан
    ' то поиск будет выполняться по первой колонке

    ' pn_RowStart - начиная с какой строки листа будет выполняться ПОИСК и изменение ячеек
    ' если не указано или указано как < 1, то начиная с первой строки листа,
    ' если же pn_RowStart > pn_RowEnd, то pn_RowStart=pn_RowEnd

    ' pn_RowEnd - по какую строку листа включительно будет выполняться ПОИСК и изменение ячеек
    ' но не более, чем последняя строка в листе, в которой есть хоть какое-то значение

    ' pn_ApplayColStart - начиная с какой колонки листа будет выполняться изменение ячеек
    ' если не указано или указано как < 1, то начиная с первой колонки листа,
    ' если же pn_ApplayColStart > pn_ApplayColEnd, то pn_ApplayColStart=pn_ApplayColEnd

    ' pn_ApplayColEnd - по какую колонку листа включительно будет выполняться изменение ячеек
    ' но не более, чем последняя колонка в листе, в которой есть хоть какое-то значение


    ' Нижеприведённые параметры затрагивают ячейки в диапазоне с pn_RowStart, pn_ApplayColStart
    ' до pn_RowEnd, pn_ApplayColEnd

    ' pn_Fontbold - если = 1 - жирный шрифт ячеек, 0 - обычный шрифт, иначе - тип шрифта НЕ меняется

    ' pc_BackColor - цвет фона ячеек, допустимые значения:
    ' "RED", "YELLOW", "GREEN", "DARKBLUE", "BLUE", "GREY", "CRIMSON", "BLACK", "WHITE"
    ' Если передано какое-то другое значение, то цвет сбрасывается в None,
    ' если же параметр не был задан, то цвет НЕ трогается вообще

    ' pc_ForeColor - цвет шрифта ячеек (см. также комментарий к pc_BackColor)

    ' pn_FontSize - номер шрифта ячеек, допустимый диапазон 6...50
    ' если номер не указан или вне данного диапазона, то шрифт НЕ меняется

    ' pu_NewValue - если был передан данный параметр, то значение данного параметра
    ' присваивается в качестве содержимого ячеек
    '
    Dim ln_rowStart As Long, ln_rowEnd As Long, ln_ColSeek As Integer, ln_NumColStart As Integer, _
      ln_NumColEnd As Integer, cl As Variant, ll_okSeek As Boolean, ln_colorIndex As Integer, _
      ln_color As Integer, iiX As Integer

    Select Case VarType(pu_SeekValue)
      Case vbString
      pu_SeekValue = UCase(Trim(pu_SeekValue))
      If Len(pu_SeekValue) < 1 Then Exit Sub
      Case vbDate, vbDecimal, vbInteger, vbLong, vbDouble, vbSingle, vbBoolean
      Case Else
      Exit Sub
    End Select
    If ExcelCheckApp(False) = False Then Exit Sub
    If VarType(pu_Sheet) = vbString Then pu_Sheet = Trim(pu_Sheet)
    If ExcelCheckExistSheet(pu_Sheet) = False Then Exit Sub
    pc_BackColor = UCase(Trim(pc_BackColor))
    pc_ForeColor = UCase(Trim(pc_ForeColor))
    Select Case pc_BackColor
      Case "BLACK"
      ln_colorIndex = 1
      Case "WHITE"
      ln_colorIndex = 2
      Case "RED"
      ln_colorIndex = 3
      Case "YELLOW"
      ln_colorIndex = 6
      Case "GREEN"
      ln_colorIndex = 4
      Case "DARKBLUE"
      ln_colorIndex = 5
      Case "BLUE"
      ln_colorIndex = 8
      Case "GREY"
      ln_colorIndex = 15
      Case "CRIMSON"
      ln_colorIndex = 7 ' малиновый
      Case Else
      ln_colorIndex = -4142 ' нет цвета
    End Select
    Select Case pc_ForeColor
      Case "BLACK"
      ln_color = 1
      Case "WHITE"
      ln_color = 2
      Case "RED"
      ln_color = 3
      Case "YELLOW"
      ln_color = 6
      Case "GREEN"
      ln_color = 4
      Case "DARKBLUE"
      ln_color = 5
      Case "BLUE"
      ln_color = 8
      Case "GREY"
      ln_color = 15
      Case "CRIMSON"
      ln_color = 7
      Case Else
      ln_color = -4142
    End Select
    'On Error GoTo err1
    With ExcelApp.Worksheets(pu_Sheet)
    ln_NumColStart = IIf(pn_ApplayColStart < 1, 1, pn_ApplayColStart)
    ln_NumColEnd = .Cells.SpecialCells(11).Column
      If pn_ApplayColEnd > 0 Then ln_NumColEnd = IIf(pn_ApplayColEnd < ln_NumColEnd, pn_ApplayColEnd, ln_NumColEnd)
      If ln_NumColEnd < ln_NumColStart Then ln_NumColStart = ln_NumColEnd
    ln_rowStart = IIf(pn_RowStart < 1, 1, pn_RowStart)
    ln_rowEnd = .Cells.SpecialCells(11).Row
      If pn_RowEnd > 0 Then ln_rowEnd = IIf(pn_RowEnd < ln_rowEnd, pn_RowEnd, ln_rowEnd)
      If ln_rowEnd < ln_rowStart Then ln_rowStart = ln_rowEnd
    ln_ColSeek = IIf(pn_InColSeek < 1, 1, pn_InColSeek)
      For Each cl In .Range(.Cells(ln_rowStart, ln_ColSeek), .Cells(ln_rowEnd, ln_ColSeek))
      If VarType(pu_SeekValue) = vbString Then
      If pl_SlowSeek Then
      ll_okSeek = InStr(1, UCase(cl.Value), pu_SeekValue) > 1
      Else
      ll_okSeek = Trim(UCase(cl.Value)) = pu_SeekValue
      End If
      Else
      ll_okSeek = cl.Value = pu_SeekValue
      End If
      If ll_okSeek Then
      If pn_Fontbold > -1 Then .Range(.Cells(cl.Row, ln_NumColStart), .Cells(cl.Row, ln_NumColEnd)).Font.Bold = pn_Fontbold = 1
      If pn_FontSize > 5 And pn_FontSize < 51 Then .Range(.Cells(cl.Row, ln_NumColStart), .Cells(cl.Row, ln_NumColEnd)).Font.Size = pn_FontSize
      If Not pc_ForeColor = "" Then .Range(.Cells(cl.Row, ln_NumColStart), .Cells(cl.Row, ln_NumColEnd)).Font.colorIndex = ln_color
      If Not pc_BackColor = "" Then .Range(.Cells(cl.Row, ln_NumColStart), .Cells(cl.Row, ln_NumColEnd)).interior.colorIndex = ln_colorIndex
      If Not IsMissing(pu_NewValue) Then
      For iiX = ln_NumColStart To ln_NumColEnd
      .Cells(cl.Row, iiX).Value = pu_NewValue
      Next
      End If
      End If
      Next
    End With

    err1:
    End Sub 
    ________________________________________

    Public Function ExcelCheckExistSheet(ByVal pu_Sheet As Variant) As Boolean
    ' Возвращает True, если лист с указанным номером или именем существует

    Dim lnCnt As Integer, iiX As Integer, ll_ExistSheet As Boolean

    If ExcelCheckApp(False) = False Then
    ExcelCheckExistSheet = False
    Exit Function
    End If
    On Error GoTo err1
    With ExcelApp
    lnCnt = .Worksheets.Count
      If VarType(pu_Sheet) = vbString Then
      pu_Sheet = Trim(pu_Sheet)
      For iiX = 1 To lnCnt
      If UCase(.Worksheets(iiX).Name) = UCase(pu_Sheet) Then
      ll_ExistSheet = True
      Exit For
      End If
      Next
      ExcelCheckExistSheet = ll_ExistSheet
      Exit Function
      End If
      If VarType(pu_Sheet) = vbInteger Then
      If pu_Sheet < 1 Then
      ExcelCheckExistSheet = False
      MsgBox "Значение передаваемого параметра pu_Sheet должно быть > 0", vbCritical + vbOKOnly, " "
      Exit Function
      End If
      ExcelCheckExistSheet = pu_Sheet <= lnCnt
      Else
      ExcelCheckExistSheet = False
      MsgBox "Тип передаваемого параметра pu_Sheet должен быть vbString или vbInteger", vbCritical + vbOKOnly, " "
      Exit Function
      End If
    End With
    Exit Function

    err1:
    ExcelCheckExistSheet = False
    End Function 
    ________________________________________

    Public Function ExcelCheckApp(Optional pl_CreateExcelObject As Boolean = False) As Boolean
    ' Возвращает True, если глобальная объектная переменная ExcelApp успешно связана с MS-Excel

    On Error GoTo err1
    If ExcelApp Is Nothing And pl_CreateExcelObject Then
      Set ExcelApp = CreateObject("Excel.Application")
    End If
    On Error GoTo errSet
    ' на тот случай если Excel был вручную вырублен через Диспетчер задач
    ExcelApp.DisplayAlerts = False
    NextSt:
    ExcelCheckApp = True
    Exit Function

    err1:
    ExcelCheckApp = False
    MsgBox "Ошибка при запуске MS-Excel !", vbCritical + vbOKOnly, " "
    Exit Function

    errSet:
    If pl_CreateExcelObject Then
      On Error GoTo err1
      Set ExcelApp = CreateObject("Excel.Application")
      GoTo NextSt
    Else
    ExcelCheckApp = False
    End If
    End Function 
    ________________________________________
    ' Примеры вызовы
    ' ? ExcelOpen("C:\Premia.xls",True, True )
    ' ? ExcelCheckApp(False)
    ' ? ExcelCheckExistSheet(2)
    ' ? ExcelRowColCount("COLUMN", "ЛисТ2")
    ' call ExcelChangeCells("МосквА", 1, False, 3, 1,,,,1,"RED","YELLOW",9)



    Категория: Полезные утилиты | Добавил: AdminGkb29 (01.04.2010)
    Просмотров: 5161 | Комментарии: 1 | Рейтинг: 0.0/0
    Всего комментариев: 0
    Добавлять комментарии могут только зарегистрированные пользователи.
    [ Регистрация | Вход ]