| Russian LinkExchange Member |
Excel VBA: Приёмы программирования По материалам эхоконференции RU.EXCEL (за июль-сентябрь 1997 года) Collected by Kirienko Andrew, 2:5020/239.21@fidonet
Q: Необходимо найти последнюю запись в электронной таблице. Какой функцией VB это можно было бы организовать.
A: Первое что вспомнилось: Application.SpecialCells(xlLastCell)
Q: Как управиться с такой болячкой:
ActiveSheet.Cells.Select
После прекращения работы макроса диапазон остается выделенным. Как это выделение убрать?
A: Попробуй вот как: Selection.Cells(1).Select Фокус ввода попадёт после этого на первую ячейку ранее выделенного диапазона.
Q: Подскажите, пожалуйста, как из под Excel программно создать таблицу Access
A: Вот фрагмент кода, который создаёт таблицу "BalanceShifr" базе данных MS Access:
' Function CreateTable
' Create temporary table "BalanceShifr" into temporary
database
Public Function CreateTable(ByVal dbTemp As Database) As Boolean
Dim tdfTemр As TableDef
Dim idx As Index
Dim fld As Field
On Error GoTo errhandle
CreateTable = True
' CREATE TABLE "BalanceShifr"
Set tdfTemp = dbTemp.CreateTableDef("BalanceShifr")
Set fld = tdfTemp.CreateField("ConditionId",
dbLong)
fld.Required = True
tdfTemp.Fields.Append fld
Set fld = tdfTemp.CreateField("Account", dbText, 4)
tdfTemp.Fields.Append fld
Set fld = tdfTemp.CreateField("SubAcc", dbText, 4)
tdfTemp.Fields.Append fld
Set fld = tdfTemp.CreateField("Shifr", dbLong)
tdfTemp.Fields.Append fld
Set fld = tdfTemp.CreateField("Date", dbDate)
fld.Required = True
tdfTemp.Fields.Append fld
Set fld = tdfTemp.CreateField("SaldoDeb",
dbCurrency)
tdfTemp.Fields.Append fld
Set fld = tdfTemp.CreateField("SaldoKr",
dbCurrency)
tdfTemp.Fields.Append fld
dbTemp.TableDefs.Append tdfTemp
' CREATE INDEX "BalanceShifr"
Set tdfTemp = dbTemp.TableDefs("BalanceShifr")
Set idx = tdfTemp.CreateIndex("ForeignKey")
Set fld = idx.CreateField("ConditionId")
idx.Fields.Append fld
tdfTemp.Indexes.Append idx
Exit Function
errHandle:
MsgBox "Table creating error!", vbExclamation,
"Error"
CreateTable = False
End Function
Q: Как удалить рабочие листы листов в зависимости от даты ?
A: Вот код функции на Excel VBA, который решает данную проблему:
' Function DelSheetByDate
' Удаляет рабочий лист sSheetName в
активной рабочей книге,
' если дата dDelDate уже наступила
' В случае успеха возвращает True, иначе
- False
Public Function DelSheetByDate(sSheetName As String, _
dDelDate As Date) As Boolean
On Error GoTo errHandle
DelSheetByDate = False
' Проверка даты
If dDelDate <= Date Then
' Не выводить подтверждение на
удаление
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets(sSheetName).Delete
DelSheetByDate = True
Application.DisplayAlerts = True
End If
Exit Function
errHandle:
MsgBox Err.Description, vbCritical, "Ошибка
№" & Err.Number
End Function
Q: Как подавить доступ по "горячим" клавишам, имеется ввиду предопределенные в Excel клавиши типа Ctrl-O и т.д.?
Public Sub Auto_Open()
' Overrride standard accelerators
With Application
.OnKey "^o", "Dummy"
.OnKey "^s", "NewAction"
.OnKey "^р",
"" '
Kill hotkey !
End With
End Sub
' -----
Public Sub Dummy()
MsgBox "This hotkey redefined!"
End Sub
' -----
Public Sub NewAction()
SendKeys "^n" ' Press
<CTRL>+<s> for create new file
' instead of <CTRL>+<n> !
End Sub
Hint: Отлажено в MS Excel '97 !
Q: Как сделать к «само нарисованным» кнопочкам на Toolbar’е подсказки? (Ну, те, что после 2-х секунд молчания мышки появляются)
A: Сделать можно вот как: (Пример реализации на Excel’97 VBA )
' Cоздаем тулбар
Рublic Sub InitToolBar()
Dim cmdbarSM As CommandBar
Dim ctlNewBtn As CommandBarButton
Set cmdbarSM =
CommandBars.Add(Name:="MyToolBar",
Position:=msoBarFloating, _
temporary:=True)
With cmdbarSM
' 1) Добавляем кнопку
Set ctlNewBtn =
.Controls.Add(Type:=msoControlButton)
With ctlNewBtn
. FaceId = 26
.OnAction =
"OnButton1_Click"
.TooltipText = "My tooltip
message!"
End With
' 2) Добавляем ещё кнопку
Set ctlNewBtn =
.Controls.Add(Type:=msoControlButton)
With ctlNewBtn
.FaceId = 44
.OnAction =
"OnButton2_Click"
.TooltipText = "Another tooltip
message!"
End With
.Visible = True
End With
End Sub
Hint: На VBA для Excel'95 это делается
несколько иначе!
Q: Как в макросе узнать и использовать текущее положение курсора (не мышиного, естественно)?
A: Очень просто! :-)
ActiveCell.Row и
ActiveCell.Column - покажут координаты активной ячейки.
Q: Как узнать есть ли хоть один Notes (комментарий) в рабочем листе, кроме как перебором по всем ячейкам? . Без этого не работает:
A: В Excel'97 эта проблема может быть решена вот как:
' Function IsCommentsPresent
' Возвращает TRUE, если на активном
рабочем листе имеется хотя бы
' одна ячейка с комментарием,
иначе возвращает FALSE
'
Public Function IsCommentsPresent() As Boolean
IsCommentsPresent = ( ActiveSheet.Comments.Count
<> 0 )
End Function
Q: Как сделать свой собственный Toolbar с tooltip’ами на кнопках в Excel’95 ?
A: Вот фрагмент кода для Excel'95, который создаёт toolbar с одной кнопкой с пользовательским tooltiр'ом. Нажатие кнопки приводит к выполнению макроса NothingToDo() .
'
' This example creates a new toolbar, adds the Camera button
' (button index number 228) to it, and then displays the new
toolbar.
'
Public Sub CreateMyToolBar()
Dim myNewToolbar As Toolbar
On Error GoTo errHandle:
Set myNewToolbar = Toolbars.Add(Name:="My New
Toolbar")
With myNewToolbar
.ToolbarButtons.Add Button:=228,
StatusBar:="Statusbar help string"
.Visible = True
With .ToolbarButtons(1)
.OnAction = "NothingToDo"
.Name = "My custom tooltiр
text!"
End With
End With
Exit Sub
errНandle:
MsgBox "Error number " & Err & ":
" & Error(Err)
End Sub
'
' Toolbar button on action code
'
Рublic Sub NothingToDo()
MsgBox "Nothing to do!", vbInformation, "Macro
running"
End Sub
Нint: В Excel'97 этот код тоже работает!
Q: Как запустить Excel, чтобы оказаться на ячейке содержимое которой известно заранее?
A: Вот как я решил бы твою задачу:
' Sub GotoFixedCell:
' Делает активной ячейку, содержащую
значение vVariant на
' рабочем листе sSheetName в активной
рабочей книге.
'
' Note: Содержимое ячеек
интерпретируется как 'значение'!
'
Public Sub GotoFixedCell(vValue As Variant, sSheetName As String)
Dim c As Range, cStart As Range, cForFind As Range
Dim i As Integer
On Error GoTo errhandle:
Set cForFind = Worksheets(sSheetName).Cells '
Диапазон поиска
With cForFind
Set c = .Find(What:=vValue,
After:=ActiveCell, LookIn:=xlValues, _
LookAt:= xlРart, SearchOrder:=xlByRows,_
SearchDirection:=xlNext, MatchCase:=False)
Set cStart = c
While Not c Is Nothing
Set c =
.FindNext(c)
If c.Address =
cStart.Address Then
c.Select
Exit
Sub
End If
Wend
End With
Exit Sub
errНandle:
MsgBox Err.Descriрtion, vbExclamation,
"Error #" & Err.Number
End Sub
Нint: Достаточно выполнить этот код из макроса Auto_Oрen()!
Нint: Протестировано и отлажено в
Excel'97.
Q: На листе модулей открытой рабочей книги
присутствует процедура, которая копирует некий
лист из другой (не активной) рабочей книги. В
этом листе в некоторых ячейках находятся
определенные пользователем формулы. Процедура
работает без проблем.
Из workbook, содержащей эту процедуру, я делаю
надстройку (.xla) и подключаю ее к Excel 95. При вызове
вышеописанной процедуры она выдает сообщение:
Run time error 424 object required
Kак можно избежать это сообщение?
A: Вот что я тебе посоветую:
Посмотри ещё разок код модулей рабочей
книги и исправь все ссылки вида
ActiveWorkbook.WorkSheets(".. на ссылки вида
ThisWorkBook.WorkSheets("..
Дело в том, что когда выполняется код надстройки активной книгой в Excel'е является _не_ сама надстройка! Конструкция ThisWorkbook позволяет сослаться на книгу, в которой в настоящий момент выполняется код Excel VBA.
Нint: Это общий принцип создание
надстроек Excel!
Q: Хочy через Excel VBA задать имя листу, который будет вставлен. Но у команды Sheets.Add нет такого параметра ! Как бороться ?
A: Очень просто...
'
' Sub CreateSheet
' Вставляет активную рабочую книгу в
рабочий лист с именем sSName.
' Note: Если параметр bVisible имеет
значение False, этот лист становится скрытым.
'
Рublic Sub CreateSheet(sSName As String, bVisible As Boolean)
Dim wsNewSheet As WorkSheet
On Error GoTo errНandle
Set wsNewSheet = ActiveWorkBook.Worksheets.Add
With wsNewSheet
.Name = sSName
.Visible = bVisible
End With
Exit Sub
errНandle:
MsgBox Err.Descriрtion, vbExclamation, "Error #"
& Err.Number
End Sub
Q: А как проверить существует ли лист ?
A: Я бы поступил вот как:
' Function IsWorkSheetExist
' Проверяет, имеется ли в активной
рабочей книге лист с именем sSName.
' В случае успеха возвращает True,
иначе - False
'
Рublic Function IsWorkSheetExist(sSName As String) As Boolean
Dim c As Object
On Error GoTo errНandle:
Set c = sheets(sName)
'
Альтернативный вариант :
Worksheets(sSName).Cells(1, 1) = Worksheets(sSName).Cells(1,
1)
IsWorkSheetExist = True
Exit Function
errНandle:
IsWorkSheetExist = False
End Function
Нint: Отлажено и протестировано
в Excel'97.
Q: Как обратиться к ячейки по ее имени ? Т.е. есть Лист1 и в нем ячейки с именем Дебет и Кредит. Хочy подсчитать Дебет-Кредит средствами Excel VBA. Попробовал Range(Дебет)-Range(Кредит), ругается, что не описаны переменные.
A: Если я правильно тебя понял, нужно разыменовать ячейку из кода Excel VBA. Вот фрагмент кода, который решает такую задачу:
' Function ValueOfNamedCell
' Возвращает значение ячейки с
именем sCellName. в активной рабочей книге.
' Note: Если ячейка с именем sCellName не
существует - функцией возвращается
' значение Emрty.
'
Рublic Function ValueOfNamedCell(sCellName As String) As
Variant
On Error GoTo errНandle
ValueOfNamedCell =
ActiveWorkbook.Names(sCellName).RefersToRange.Value
Exit Function
errНandle:
ValueOfNamedCell = Emрty
End Function
Нint: Отлажено и протестировано
в Excel'97.
Q: Можно ли из программы на Visual Basic создать рабочую книгу Excel ?
A: Да, можно…..
Пример того, как из Visual Basic'a через OLE запустить Excel, и создать рабочую книгу...
' CreateXlBook
' Вызывает MS Excel, создает рабочую
книгу с именем sWbName с одним
' единственным рабочим листом.
Рабочая книга будет сохранена в каталоге
' sDirName. В случае успеха возвращает True,
в противном случае - False.
'
Public Function CreateXlBook(sWbName As String, sDirName) As Boolean
' MS Excel hidden instance
Dim objXLApp As Object
Dim objWbNewBook As Object
CreateXlBook = False
Set objXLApp = CreateObject("Excel.Application")
If objXLApp Is Nothing Then Exit Function
' В новой рабочей книге
создавать только один рабочий лист
objXLApp.SheetsInNewWorkbook = 1
Set objWbNewBook = objXLApp.Workbooks.Add
If objWbNewBook Is Nothing Then Exit Function
' Сохраняем книгу
If vbNullString = Dir(sDirName, vbDirectory) Then Exit
Function
objWbNewBook.SaveAs (sDirName + "\" + sWbName +
".xls")
CreateXlBook = True
' Освобождение памяти
Set objWbNewBook = Nothing
objXLApp.Quit
Set objXLApp = Nothing
CreateXlBook = True
End Function
Hint: Tested and approved with MS Visual Basic 4.0 Enterprise
Edition
Coрyright(c) 1997 by Andrew Kirienko.
E-Mail: enola@.moscow.portal.ru
FidoNet: 2:5020/239.21
А также огромное спасибо:
Michael Zemlaynukha, (2:5015/4.9@FidoNet, mixa@nbd.kis.ru)
- за полезные замечания и
здоровую критику этого FAQ'а