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