|
|
Каталог статей
Перенос данных из 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)
|
| Просмотров: 7292 | Комментарии: 1
| Рейтинг: 0.0/0 |
Добавлять комментарии могут только зарегистрированные пользователи. [ Регистрация | Вход ] |
