Logo Море(!) аналитической информации!
IT-консалтинг Software Engineering Программирование СУБД Безопасность Internet Сети Операционные системы Hardware
VPS в 21 локации

От 104 рублей в месяц

Безлимитный трафик. Защита от ДДоС.

🔥 VPS до 5.7 ГГц под любые задачи с AntiDDoS в 7 локациях

💸 Гифткод CITFORUM (250р на баланс) и попробуйте уже сейчас!

🛒 Скидка 15% на первый платеж (в течение 24ч)

Скидка до 20% на услуги дата-центра. Аренда серверной стойки. Colocation от 1U!

Миграция в облако #SotelCloud. Виртуальный сервер в облаке. Выбрать конфигурацию на сайте!

Виртуальная АТС для вашего бизнеса. Приветственные бонусы для новых клиентов!

Виртуальные VPS серверы в РФ и ЕС

Dedicated серверы в РФ и ЕС

По промокоду CITFORUM скидка 30% на заказ VPS\VDS

2000 г

Excel VBA: Приёмы программирования 

По материалам эхоконференции RU.EXCEL (за июль-сентябрь 1997 года) Collected by Kirienko Andrew, 2:5020/239.21@fidonet

Cодержание

  1. Как определить последнюю запись в таблице Excel?
  2. Как отменить выделение диапазона ячеек?
  3. Как из макроса Excel программно создать таблицу Access?
  4. Удаление листов в зависимости от даты.
  5. Подавление "горячих" клавиш
  6. Подсказки к Toolbar
  7. Как определить адрес активной ячейки.
  8. Подсчет комментариев на рабочем листе.
  9. Подсказки к Toolbar (Excel'95).
  10. Запуск Excel с поиском ячейки
  11. ThisWorkBook или ActiveWorkBook?
  12. Как задать имя листу, который будет вставлен?
  13. Как проверить существует ли лист?
  14. Как обратиться к ячейке по ее имени?
  15. Можно ли из программы на Visual Basic создать рабочую книгу Excel?

Как определить последнюю запись в таблице Excel?

Q: Необходимо найти последнюю запись вэлектронной таблице. Какой функцией VB это можно было бы организовать.

A: Первое что вспомнилось: Application.SpecialCells(xlLastCell)

Назад к СОДЕРЖАНИЮ


Как отменить выделение диапазона ячеек?

Q: Как управиться с такой болячкой:

ActiveSheet.Cells.Select

После прекращения работы макроса диапазон остается выделенным. Как это выделение убрать?

A: Попробуй вот как: Selection.Cells(1).Select Фокус ввода попадёт после этого на первую ячейку ранее выделенного диапазона.

Назад к СОДЕРЖАНИЮ


Как из макроса Excel программно создать таблицу Access?

Q: Подскажите, пожалуйста, как из под Excel программно создать таблицу Access

A: Вот  фрагмент кода, который создаёт таблицу "BalanceShifr" базе  данных MS Access:

Нint: Не забудьте выставить в Excel ссылки на объекты DAO!
[VBA] Tools/References/Available References/ [x] MicroSoft DAO?.? Library ' 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 и т.д.?

A:Вот  малюсенький исходник на Excel VB, который решает такую проблему. :-)

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 !  

Назад к СОДЕРЖАНИЮ


Подсказки к Toolbar

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

Назад к СОДЕРЖАНИЮ


Подсказки к Toolbar (Excel'95)

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 этот код тоже работает!

Назад к СОДЕРЖАНИЮ


Запуск Excel с поиском ячейки

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.

Назад к СОДЕРЖАНИЮ


ThisWorkBook или ActiveWorkBook?

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.

Назад к СОДЕРЖАНИЮ


Можно ли из программы на Visual Basic создать рабочую книгу Excel?

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'а

 

VPS/VDS серверы. 30 локаций на выбор

Серверы VPS/VDS с большим диском

Хорошие условия для реселлеров

4VPS.SU - VPS в 17-ти странах

2Gbit/s безлимит

Современное железо!

Бесплатный конструктор сайтов и Landing Page

Хостинг с DDoS защитой от 2.5$ + Бесплатный SSL и Домен

SSD VPS в Нидерландах под различные задачи от 2.6$

✅ Дешевый VPS-хостинг на AMD EPYC: 1vCore, 3GB DDR4, 15GB NVMe всего за €3,50!

🔥 Anti-DDoS защита 12 Тбит/с!

Новости мира IT:

Архив новостей

IT-консалтинг Software Engineering Программирование СУБД Безопасность Internet Сети Операционные системы Hardware

Информация для рекламодателей PR-акции, размещение рекламы — adv@citforum.ru,
тел. +7 495 7861149
Пресс-релизы — pr@citforum.ru
Обратная связь
Информация для авторов
Rambler's Top100 TopList liveinternet.ru: показано число просмотров за 24 часа, посетителей за 24 часа и за сегодня This Web server launched on February 24, 1997
Copyright © 1997-2000 CIT, © 2001-2019 CIT Forum
Внимание! Любой из материалов, опубликованных на этом сервере, не может быть воспроизведен в какой бы то ни было форме и какими бы то ни было средствами без письменного разрешения владельцев авторских прав. Подробнее...